#!/usr/bin/perl
#
# BlockCountries     Block IP traffic from specified countries
#
# chkconfig: 2345 10 92
# description:  Blocks IP traffic from IP addresses assigned to specific countries
#

use strict;
use warnings;

# Version 1.4
#
# Copyright (c) 2010 Timothe Litt, litt__at__acm_dot_org
#  All rights reserved.
#
# This software is licensed under the terms of the Perl
# Artistic License (see http://dev.perl.org/licenses/artistic.html).
#
# This is free software - it works for me, and it may (or may not)
# work for you.  No warranty or support is provided.
#
# Consider carefully whether you want to use this software
# and the full consequences to your site and/or business.
#
# This is written as a technical means to assist in implementing
# your policy.  The author expressly disclaims any responsibility
# for the consequences of using this software.

### Block all traffic from specified countries. ###
#
# See Usage() for documentation
#

# List of country codes - specify yours in the config file

my @DEFAULT_ISO = qw /cn kr kp kz ru/;

# Local configuration

my $IPT = '/sbin/iptables';
my $IPTR = '/sbin/iptables-restore';
my $GREP = '/bin/grep';

my $CFGFILE = '/etc/sysconfig/BlockCountries';

my $ZONEDIR = '/root/blockips';
my $ZONETBL = "$ZONEDIR/tables.ipt";
my $BLOCKURL = 'http://www.ipdeny.com/ipblocks/data/countries';

my $LOGPFX = '[Blocked CC]: ';
my $LOG = '/var/log/messages*';  # Note: This is a wildcard to handle log rotation.  .gz files will decompressed on the fly and processed.
my $LOGPGM = 'kernel';
my $IHOOK = 'INPUT-HOOK';       # Note: if this table is not found, INPUT will be used
my $OHOOK = 'OUTPUT-HOOK';      # Note: if this table is not found, OUTPUT will be used
my $FHOOK = 'FORWARD-HOOK';     # Note: if this table is not found, FORWARD will be used
# ### End of configuration

# The following are either part of base perl, or available on CPAN

use File::Basename;
use File::Path;
use IO::Uncompress::Gunzip;
use Locale::Country;
use LWP::Simple;
use NetAddr::IP;
use Net::Domain;
use Parse::Syslog;
use POSIX;
use Text::ParseWords;

# Changelog (Also update revision above!)
# 1.0       Initial development
# 1.1       Add support for hook tables
# 1.2       By unpopular demand, add -permitonly
#           Add logging rate limit
#           Add -dip (deny IP)
# 1.3       Add output filtering (-blockout)
# 1.4       Output filters need to match on destination port.
#           Separate output port overrides as trojans like to ride on well-known ports

umask 0137;

my $prog = basename $0;

# new, old
my @IPCHAINS = ( 'BLOCKCC0', 'BLOCKCC1' );

@IPCHAINS = reverse( @IPCHAINS ) if( system( "$IPT -n -L $IPCHAINS[0]-I >/dev/null 2>&1" ) == 0 );
my $IPNEWCHAIN = $IPCHAINS[0];
my $IPOLDCHAIN = $IPCHAINS[1];

$IHOOK = 'INPUT' unless( system( "$IPT -n -L $IHOOK >/dev/null 2>&1" ) == 0 );
$OHOOK = 'OUTPUT' unless( system( "$IPT -n -L $OHOOK >/dev/null 2>&1" ) == 0 );
$FHOOK = 'FORWARD' unless( system( "$IPT -n -L $FHOOK >/dev/null 2>&1" ) == 0 );

if( -e $CFGFILE ) {
    open( my $fh, '<', $CFGFILE ) or die( "Can't open $CFGFILE:$!" );
    while( <$fh> ) {
        s/\s*#.*$//;
        s/^\s+//;
        s/\s+$//;
        next unless length;
        push @ARGV, parse_line( '\s+', 0, $_ );
    }
    close $fh;
}

my $cmd = shift;

# Collect all arguments here, even though they are mostly for start
# This allows detailed status

my( $debug, $verbose, @iso, %iso, $update, $log, $days, $host, $permitonly, $outrules, @loglimits, @atports, @auports, @atportso, @auportso, @aips, @dips );
@loglimits = ( '1/minute', 10 );

while( (my $arg = shift) ) {
    if( $arg =~ /^-/ ) {
        if( $arg eq '-update' ) {
            $update = 1;
            next;
        }
        if( $arg eq '-log' ) {
            $log = 1;
            next;
        }
        if( $arg eq '-limit' && $ARGV[0] ) {
            unless( $ARGV[0] =~ m#(\d+/(?:second|minute|hour|day))(?::(\d+))?# ) {
                print "Syntax error in -limit\n";
                exit 1;
            }
            shift;
            $loglimits[0] = $1;
            $loglimits[1] = $2 if( defined $2 );
            next;
        }
        if( $arg eq '-nolimit' ) {
            @loglimits = ();
            next;
        }
        if( $arg eq '-nolog' ) {
            $log = 0;
            next;
        }
        if( $arg eq '-permitonly' ) {
            $permitonly = 1;
            next;
        }
        if( $arg eq '-d' ) {
            $debug = 1;
            next;
        }
        if( $arg eq '-blockout' ) {
            $outrules = 1;
            next;
        }
        if( $arg eq '-v' ) {
            $verbose = 1;
            next;
        }
        if( $arg eq '-days' && $ARGV[0] && $ARGV[0] =~ /^\d+$/ ){
            $days = shift;
            next;
        }
        if( $arg eq '-host' && $ARGV[0] ){
            $host = shift;
            next;
        }
        if( $arg eq '-atport' && $ARGV[0] ){
            $arg = shift;
            if( $arg =~  /^(?:\d+)$/ ) {
                push @atports, $arg;
                next;
            }
            my $val = getservbyname( $arg, 'tcp' );
            if( defined $val ) {
                push @atports, $val;
                next;
            }
            print "Invalid port $arg\n";
            exit 1;
        }
        if( $arg eq '-auport' && $ARGV[0] ){
            $arg = shift;
            if( $arg =~  /^(?:\d+)$/ ) {
                push @auports, $arg;
                next;
            }
            my $val = getservbyname( $arg, 'udp' );
            if( defined $val ) {
                push @auports, $val;
                next;
            }
            print "Invalid port $arg\n";
            exit 1;
        }
        if( $arg eq '-atporto' && $ARGV[0] ){
            $arg = shift;
            if( $arg =~  /^(?:\d+)$/ ) {
                push @atportso, $arg;
                next;
            }
            my $val = getservbyname( $arg, 'tcp' );
            if( defined $val ) {
                push @atportso, $val;
                next;
            }
            print "Invalid port $arg\n";
            exit 1;
        }
        if( $arg eq '-auporto' && $ARGV[0] ){
            $arg = shift;
            if( $arg =~  /^(?:\d+)$/ ) {
                push @auportso, $arg;
                next;
            }
            my $val = getservbyname( $arg, 'udp' );
            if( defined $val ) {
                push @auportso, $val;
                next;
            }
            print "Invalid port $arg\n";
            exit 1;
        }
        if( $arg eq '-aip' && $ARGV[0] ) {
            if( $ARGV[0] =~ /^\d{1,3}(?:\.\d{1,3}){0,3}(?:\/(?:\d+|(?:\d{1,3}(?:\.\d{1,3}){3})))?$/ ){
                push @aips, NetAddr::IP->new( shift );
                next;
            }
            my @h = gethostbyname( $ARGV[0] );
            unless( @h) {
                print "Unknown host $ARGV[0]\n";
                exit 1;
            }
            unless( $h[3] == 4 && $#h >= 4 ) {
                print "$ARGV[0] : not an IPV4 address\n";
                exit 1;
            }
            for my $a (@h[4..$#h]) {
                push @aips, NetAddr::IP->new( sprintf( "%vd", $a ) );
            }
            shift;
            next;
        }
        if( $arg eq '-dip' && $ARGV[0] ) {
            if( $ARGV[0] =~ /^\d{1,3}(?:\.\d{1,3}){0,3}(?:\/(?:\d+|(?:\d{1,3}(?:\.\d{1,3}){3})))?$/ ){
                push @dips, NetAddr::IP->new( shift );
                next;
            }
            my @h = gethostbyname( $ARGV[0] );
            unless( @h) {
                print "Unknown host $ARGV[0]\n";
                exit 1;
            }
            unless( $h[3] == 4 && $#h >= 4 ) {
                print "$ARGV[0] : not an IPV4 address\n";
                exit 1;
            }
            for my $a (@h[4..$#h]) {
                push @dips, NetAddr::IP->new( sprintf( "%vd", $a ) );
            }
            shift;
            next;
        }
        if( $arg eq '-h' || $arg eq '--help' ) {
            Usage();
            exit 0;
        }
        print "Unknown switch $arg";
        print ' ', $ARGV[0] if( defined $ARGV[0] );
        print "\n";
        exit 1;
    }
    if( defined code2country( $arg ) ) {
        $iso{lc $arg} = 1;
    } else {
        my $cc = country2code( $arg );
        if( defined $cc ) {
            $iso{lc $cc} = 1;
        } else {
            print "Unrecognized country/country code: $arg\n";
            exit 1;
        }
    }
}

@iso = sort keys %iso;
@iso = @DEFAULT_ISO unless( @iso );

my @genlist = $outrules? qw/I O/ : 'I';

sub Usage {
    print << "HELP";
IP filter manager for country filters

Usage: $prog command args
  status [-v]        Display filter status
                     -v provides configuration from config file
                     and command file - NOT iptables.
  list               List available country names/codes
                       Contacts server for list.
  intercepts [-host name] [-days n]
                     List today\'s intercepts by host (from $LOG)
                     Requires -log
  stop               Stop filtering
  restart  args      Synonym for start (reloads with no open window)
  condrestart args   Restarts only if already running
  start args         Starts filter

Start uses tables of IP blocks assigned to country codes that are
stored in $ZONEDIR, which will be created if necessary.  The data
is obtained from $BLOCKURL when needed,
or when start -update is specified.

iptables filters are generated and installed by start.  The filters are
optimized and generally will not look identical to the input data.  However
they will match the same address (no more and no fewer.)

Arguments for start-class commands are:
 -update            Get latest data for active country codes.
                    Otherwise, only gets data if no local file exists for a CC.
 -log               Install a logging rule to log rejected packets.
 -nolog             Don\'t install a logging rule (default)
 -nolimit           Do not limit logging (can generate huge log files if under attack; not advised)
 -limit spec        Limit logging, default = $loglimits[0]:$loglimits[1] (see man iptables "limit")
 -atport n          Allow connections to TCP port n even FROM banned addresses.
                    May specify any number of times.  May use a service name.
 -auport n          Allow connections to UDP port n even FROM banned addresses.
                    May specify any number of times.  May use a service name.
 -atporto n         Same as -atport, but for connections TO banned addresses.
 -auporto n         Same as -auport, but for connections TO banned addresses.
 -aip ip(\/mask)    Allow connection from an otherwise banned IP address.
                    For a block, specify a netlength or mask. A hostname may
                    also be specified.
 -dip ip(\/mask)     Deny connections from an otherwise allowed IP address.
                    Same syntax as -aip
 -permitonly        Listed countries will be permited, all others denied
 -blockout          Also generate rules to block output & forwarded-output
                    This is probably not required for most applications, and
                    will roughly double the memory requirements.
                    Caution: If you use -blockout for start, you must also use it for stop.
                    This will not be a problem if it\'s in the config file.
 -d                 Output random debugging messages
 -v                 Output extended status/statistics
  CC                ISO Country code or name to ban (as many as you like)
                    Default list:
HELP
    for my $cc (sort @DEFAULT_ISO ) {
        print "                      $cc - ", code2country($cc), "\n";
    }
    print << "HELP";

Arguments may also be obtained from $CFGFILE.
Anything (except comments) contained in it is appended to every command line.
Use single or double-quoted strings for country names including spaces.

This script is designed to run as a service; chkconfig will link it into
/etc/rcn.d/.

This script should also be run with start -update from a cron job - weekly
is suggested - to obtain the latest IP address databases.  If the CRONJOB
environment variable is set, only errors and zone updates will be reported.
This minimizes e-mail from cron.

To prevent communications from banned IP addresses during updates,
start will install new rules before removing active rules.  For
this to be effective, you should not stop the service.

The status -v command will report the current configuration, although the
actual implementation in iptables will be different due to optimizations.

start -v will provide some statistics for the optimizations and generated rules.

The intercepts command will parse $LOG and summarize intercepts by IP address.
It will break down the dropped packets by protocol(s) and port(s).  Of course,
logging must be on for this to work.  -days specifys how many days back
(from the current time) to read.  -host specifies the hostname to match.
Default -days is 1, hostname is current host.

Credits:
 Some ideas came from http://www.cyberciti.biz/faq/block-entier-country-using-iptables/.

 This version of the script merges all the IP address blocks; this saves over 1,000
 rules for the default banned address list.  It\'s also somewhat faster than a shell
 script, and contains a more complete and polished user and system interface.

Issues:
 Consider carefully whether you want to use this software and the full consequences
 to your site and\/or business.  By necessity, it will block potential customers and
 'good' connections along with villains.  You must consider the costs and benefits
 to your operation - the author does not endorse any specific policy.  In particular,
 the defaults should be viewed as examples, not value judgements.

 If you use selinux (and you should), you may have to create a policy allowing
 $IPTR to access $ZONETBL.

 Very large numbers of exception IP blocks might benefit from implementing a subchain
 structure - but that would be a rather different use model.  The known use cases
 would probably be penalized - so one would want to make a dynamic choice.  I\'d
 want to see actual data before implementing this.

 The iptables-restore format is undocumented, though used by others.  It may be
 fragile.

 This code should use IPTables::IPv4 - but it doesn\'t currently work on my x64 system.
 It may be re-written to do so at some point.

 --tlhackque 1-Aug-2010
HELP
}

# Success and failure return true and false, and
# print boot-compatible strings (color and aligned
# to column 60 if on a terminal)
# CHA (...G)
# SGR codes used (...m)
# 0 = default; 1 = bold; 31 = green, 32 = red; 1 = bold; 39 = "default" (boot requires)

sub success {
    return 1 if( $ENV{CRONJOB} );

    if( -t STDOUT ) {
        print "\033[60G[\033[1;32m OK \033[0;39m]\n";
    } else {
        print " [ OK ]\n";
    }
    return 1;
}

sub failure {
    return 0 if( $ENV{CRONJOB} );

    if( -t STDOUT ) {
        print "\033[60G[\033[1;31m FAILED \033[0;39m]\n";
    } else {
        print " [ FAILED ]\n";
    }
    return 0;
}

sub running {
    return system( "$IPT -n -L $IHOOK | $GREP -q -P '^$IPOLDCHAIN-\[IO\]\\s+'" ) == 0;
}

sub pport {
    my $p = shift;
    my @p = @_;

    printf "  %5u", $p;
    if( @p ) {
        print " $p[0]";
        if( length $p[1] ) {
            print " (", join( '/', split( ' ', $p[1] ) ), ")";
        }
    }
    print "\n";
}

sub status {
    if( running ) {
        print "Blocked countries IP filter is running";
        if( $verbose ) {
            printf " and configured to %s:\n", ($permitonly? 'permit only' : 'block');
            for my $cc (sort @iso ) {
                print " $cc - ", code2country($cc), "\n";
            }
            if( (my $n = @atports + @auports + @atportso + @auportso + @aips + @dips) ) {
                printf "However, the following exception%s exist:\n", ($n == 1)? ' is' : 's are';
                if( @atports ) {
                    printf " TCP port%s permitted (input):\n", ((@atports == 1)? '' : 's');
                    for my $p (@atports) {
                        pport( $p,  getservbyport($p, 'tcp') );
                    }
                }
                if( @atportso ) {
                    printf " TCP port%s permitted (output):\n", ((@atportso == 1)? '' : 's');
                    for my $p (@atportso) {
                        pport( $p,  getservbyport($p, 'tcp') );
                    }
                }
                if( @auports ) {
                    printf " UDP port%s permitted (input):\n", ((@auports == 1)? '' : 's');
                    for my $p (@auports) {
                        pport( $p, getservbyport($p, 'udp') );
                    }
                }
                if( @auportso ) {
                    printf " UDP port%s permitted (output):\n", ((@auportso == 1)? '' : 's');
                    for my $p (@auportso) {
                        pport( $p, getservbyport($p, 'udp') );
                    }
                }
                if( @aips ) {
                    printf " IP %s permitted:\n", ((@aips == 1)? 'address/network' : 'addresses/networks');
                    for my $ip (@aips) {
                        printf "    $ip\n";
                    }
                }
                if( @dips ) {
                    printf " IP %s blocked:\n", ((@dips == 1)? 'address/network' : 'addresses/networks');
                    for my $ip (@dips) {
                        printf "    $ip\n";
                    }
                }
            }
        } else {
            print "\n";
        }
        return 1;
    }
    print "Blocked countries IP filter is stopped\n";
    return 0;
}

sub list {
    my $list = get( $BLOCKURL );
    unless( defined $list ) {
        print "Unable to contact $BLOCKURL for listing\n";
        return 0;
    }

    print "Recognized country codes:\n";
    my @ccs = $list =~ /href=['"](..)\.zone["']/gm;

    for my $cc (sort @ccs) {
        my $cn = code2country($cc);
        next unless( defined $cn ); # There seem to be some undocumented zones
        printf " $cc - %s\n", $cn
    }
    return 1;
}

sub delsubchains {
    my $chain = shift;

    # List sub-chains of the form NAME-[IO]-nnn


    my @schains = map { (m/^($chain-\d+)\s/ ? ( $1, ) : ()) } split( /\n/, `$IPT -n -L $chain 2>/dev/null`);

    # Delete each one
    #  First, delete the rule in the main chain that reads '-s 1st octet, goto subchain'
    #  Then empty and delete the subchain

    for my $schain (@schains) {
        $schain =~ m/-([IO])-(\d+)$/;
        system( "$IPT -D $chain -" . ($1 eq 'I'? 's' : 'd' ) . " $2.0.0.0/8 -g $schain" );
        system( "$IPT -F $schain" );
        system( "$IPT -X $schain" );
    }
}

sub delchainref {
    my $main = shift;  # e.g. INPUT
    my $chain = shift; # e.g. BLOCKchain
    my @crefs = map { (m/^$chain\s/ ? ( $chain, ) : ()) } split( /\n/, `$IPT -n -L $main 2>/dev/null`);

    for my $cref (@crefs) { # should be only one
        system( "$IPT -D $main -j $cref" );
    }
}

# Sort function for IP addresses for installation into filter chains
# The whole chain must be processed if we miss, so there's nothing we can do.
# But on a hit, we can improve the expected time somewhat by checking the
# largest blocks first.  This corresponds to the smallest mask length.
# It is possible to do better if the traffic pattern is known, but there
# isn't a good way (short of active feedback) to determine it.
# In any case, we reduce the search length by hashing on the first
# octet of the address, so this is a secondary effect.

sub ipcmp {
    my $x = $a->masklen <=> $b->masklen;
    return $x if( $x );
    return $a <=> $b;
}

sub start {
    print "Starting blocked countries IP filter: " unless( $ENV{CRONJOB} );

    File::Path::make_path( $ZONEDIR, { mode => 0771 } ) unless( -d $ZONEDIR );

    # Delete any lingering references / parts of new chain

    delchainref( $IHOOK, "$IPNEWCHAIN-I" );

    delchainref( $OHOOK, "$IPNEWCHAIN-O" );
    delchainref( $FHOOK, "$IPNEWCHAIN-O" );

    delsubchains( "$IPNEWCHAIN-I" );
    delsubchains( "$IPNEWCHAIN-O" );
    foreach my $pchain ( @genlist ) {
        system( "$IPT -F $IPNEWCHAIN-$pchain >/dev/null 2>&1" );
        system( "$IPT -X $IPNEWCHAIN-$pchain >/dev/null 2>&1" );
    }

    # (Log & ) drop chain

    system( "$IPT -F $IPNEWCHAIN-DLOG >/dev/null 2>&1" );
    system( "$IPT -X $IPNEWCHAIN-DLOG >/dev/null 2>&1" );
    return failure unless( system( "$IPT -N $IPNEWCHAIN-DLOG" ) == 0 );
    if( $log ) {
        # Note that we can not provide a per-country log prefix due to compaction.
        # However, the intercepts report will map IPs back to their (alleged) country of origin
        # To determine what countries are causing intercepts, the logs must be post-processed to
        # lookup each IP.
        my $limits = "";
        $limits = "-m limit --limit $loglimits[0] --limit-burst $loglimits[1] " if( @loglimits );
        return failure unless( system( "$IPT -A $IPNEWCHAIN-DLOG $limits-j LOG --log-prefix \"$LOGPFX\"" ) == 0 );
    }
    return failure unless( system( "$IPT -A $IPNEWCHAIN-DLOG -j DROP" ) == 0 );

    # Local subnets - external firewalls prevent them from showing up here, but
    # a bogus zone file could do damage.
    unshift @aips, NetAddr::IP->new( '192.168.0.0/16' ), NetAddr::IP->new( '172.16.0.0/12' ), NetAddr::IP->new( '10.0.0.0/8' );

    # Optimize  IP lists
    @aips = sort ipcmp NetAddr::IP::Compact( @aips );
    @dips = sort ipcmp NetAddr::IP::Compact( @dips );

    # Make sure we have a zone file for each country code
    # Fetch a new one if -update or we don't have one
    # If we fetch, only transfer the file if it's different from (usu. newer than) our copy.

    my @files;
    for my $c (@iso) {
        my $db = "$ZONEDIR/$c.zone";
        my $cn = code2country( $c );
        $cn = " ($cn)" if( defined $cn );

        # Fetch if updating or have no data

        if( $update || ! -f $db || -z $db ) {
            my $rc = mirror( "$BLOCKURL/$c.zone", $db );
            if( is_success( $rc ) ) {

                print "\nUpdated IP zone data for $c$cn", if( $debug || $update || $ENV{CRONJOB} );
                # Shouldn't ever get an empty file, but may as well check
                unless( -f $db && -s $db ) {
                    print "\nUpdated zone data for $c$cn is empty!";
                    unlink $db;
                    return failure;
                }
            } else {
                if( $rc == RC_NOT_MODIFIED ) { # Can only happen if file exists
                    print "\nNo new IP data available for $c$cn " if( $debug || ($update && !$ENV{CRONJOB}) );
                } else {
                    print "\nUnable to fetch IP zone data for $c$cn: $rc - ", status_message($rc), " ";
                }
                unless( -f $db && -s $db ) {
                    # No data - don't replace current filter
                    print "\nNo IP zone data available for $c$cn ";
                    if( $debug ) {
                        next;
                    }
                    return failure;
                }
                # Failed, but have old file, continue since other zones may be updated
            }
        }
        push @files, $db;
    }

    return failure unless( @files );


    # Parse the zone files and create a list of IP blocks

    my @addresses = ();
    for my $if (@files) {
        open( my $ifh, '<', $if ) or die( "Can't open $if: $!" );
        while( <$ifh> ) {
            s/\s*#.*$//;
            next unless( length );
            push @addresses, NetAddr::IP->new( $_ );
        }
        close $ifh;
    }
    return failure unless( @addresses );

    # Compact the blocks into the minimal covering set
    my $inaddrs = @addresses;

    @addresses = sort ipcmp NetAddr::IP::Compact(@addresses);

    open( my $fh, '>', $ZONETBL ) or die( "Can't open $ZONETBL: $!" );
    print $fh "# Generated by $prog on ", (scalar localtime), "\n",
              "*filter\n";           # table

    my( $exceptions, $xrules ) = (0,0);
    foreach my $pchain ( @genlist ) {
        return failure unless( system( "$IPT -N $IPNEWCHAIN-$pchain" ) == 0 );
        return failure unless( system( "$IPT -A $IPNEWCHAIN-$pchain -m state --state RELATED,ESTABLISHED -j RETURN" ) == 0 );

        # List any allowed ports - first since they have a netmask of 0

        # Allowed TCP ports - no more than 15 per rule (limit of multiport)

        $exceptions += @aips + @dips;

        my @ports = ($pchain eq 'I')? @atports : @atportso;
        $exceptions += @ports;
        while( @ports ) {
            my $n = @ports;
            $n = 15 if( $n > 15 );
            return failure unless( system( "$IPT -A $IPNEWCHAIN-$pchain -p tcp -m multiport --dports " . join( ',', @ports[0..$n-1] ) . ' -j RETURN' ) == 0 );
            splice( @ports, 0, $n );
            $xrules++;
        }

        # Allowed UDP ports

        @ports = ($pchain eq 'I')? @auports : @auportso;
        $exceptions += @ports;

        while( @ports ) {
            my $n = @ports;
            $n = 15 if( $n > 15 );
            return failure unless( system( "$IPT -A $IPNEWCHAIN-$pchain -p udp -m multiport --dports " . join( ',', @ports[0..$n-1] ) . ' -j RETURN' ) == 0 );
            splice( @ports, 0, $n );
            $xrules++;
        }

        # Allowed IPs (with optional masklen/netmask); largest size first
        #

        $xrules += @aips;
        my $match = ($pchain eq 'I' ? 's' : 'd');
        my @ips = @aips;
        while( @ips ) {
            return failure unless( system( "$IPT -A $IPNEWCHAIN-$pchain -$match " . shift( @ips ) . ' -j RETURN' ) == 0 );
        }

        # Explicitly blocked IPs

        $xrules += @dips;
        @ips = @dips;
        while( @ips ) {
            return failure unless( system( "$IPT -A $IPNEWCHAIN-$pchain -$match " . shift( @ips ) . " -j $IPNEWCHAIN-DLOG" ) == 0 );
        }


        # Generate iptables-restore data

        my %subchains;

        # Note: Do not include input hook table declaration as this will clear it
        # It is guaranteed to exist because we checked earlier

        if( $pchain eq 'I' ) {
            if( $IHOOK eq 'INPUT' ) {
                print $fh ":INPUT ACCEPT [0:0]\n"; # built-in chain, policy, counters
            }
        } elsif( $pchain eq 'O' ) {
            if( $OHOOK eq 'OUTPUT' ) {
                print $fh ":OUTPUT ACCEPT [0:0]\n"; # built-in chain, policy, counters
            }
            if( $FHOOK eq 'FORWARD' ) {
                print $fh ":FORWARD ACCEPT [0:0]\n"; # built-in chain, policy, counters
            }
        }

        foreach my $ipblock (@addresses) {
            $ipblock =~ /^(\d+)\./;
            unless( $subchains{$1} ) {
                print $fh ":$IPNEWCHAIN-$pchain-$1 - [0:0]\n",    # subchain, no policy, zero counters
                          "-A $IPNEWCHAIN-$pchain -$match $1.0.0.0/8 -g $IPNEWCHAIN-$pchain-$1\n";  # Chain - branch on 1st octet to subchain
            }
            $subchains{$1}++;
            if( $permitonly ) {
                print $fh "-A $IPNEWCHAIN-$pchain-$1 -$match $ipblock -j RETURN\n"; # Subchain, accept
            } else {
                print $fh "-A $IPNEWCHAIN-$pchain-$1 -$match $ipblock -j $IPNEWCHAIN-DLOG\n"; # Subchain, branch on match to log & drop
            }
        }
        if( $permitonly ) {
            foreach my $subchain (keys %subchains) {
                print $fh "-A $IPNEWCHAIN-$pchain-$subchain -j $IPNEWCHAIN-DLOG\n";
            }
        }

        if( $verbose && $pchain eq 'I' ) {
            # Statistics are identical for each chain
            my( $minlen, $maxlen );
            $minlen = $maxlen = $subchains{(keys %subchains)[0]};
            for my $s (values %subchains) {
                $minlen = $s if( $s < $minlen );
                $maxlen = $s if( $s > $maxlen );
            }
            print( "\n",
                   $inaddrs . ($permitonly? ' permitted' : ' blocked') . " address ranges generated ",
                   (scalar @addresses), " rules, using ",
                   (scalar keys %subchains), " sub-chains.  Savings: ",
                   ($inaddrs - scalar @addresses), " rules (",
                   sprintf( "%.2f", 100*(1- ((scalar @addresses))/$inaddrs)), "%).  Minimum chain length: $minlen",
                   ", Maximum: $maxlen\n" );
        }
    }

    print $fh "COMMIT\n",
              "# Completed on ", (scalar localtime), "\n";
    close $fh or die "Close failed for $ZONETBL: $!\n";

    if( $verbose ) {
        # Provide some statistics, mostly for debugging.

        # Exception statistics
        print( "\n",
               "$exceptions exceptions generated $xrules rules." );
    }

    # Install new ruleset

    # -- Mass-install new Chain, subchains & rules
    return failure unless( system( "$IPTR -n $ZONETBL" ) == 0 );

    # -- Link INPUT to the new chain
    return failure unless( system( "$IPT -I $IHOOK -j $IPNEWCHAIN-I" ) == 0 );

    # -- Link OUTPUT and FORWARD to the new chains if we generated them.

    if( $outrules ) {
        return failure unless( system( "$IPT -I $OHOOK -j $IPNEWCHAIN-O" ) == 0 );
        return failure unless( system( "$IPT -I $FHOOK -j $IPNEWCHAIN-O" ) == 0 );
    }

    # Remove old rules
    delchainref( $IHOOK, "$IPOLDCHAIN-I" );
    delchainref( $OHOOK, "$IPOLDCHAIN-O" );
    delchainref( $FHOOK, "$IPOLDCHAIN-O" );

    delsubchains( "$IPOLDCHAIN-I" );
    delsubchains( "$IPOLDCHAIN-O" );

    foreach my $pchain ( @genlist ) {
        system( "$IPT -F $IPOLDCHAIN-$pchain >/dev/null 2>&1" );
        system( "$IPT -X $IPOLDCHAIN-$pchain >/dev/null 2>&1" );
    }

    system( "$IPT -F $IPOLDCHAIN-DLOG >/dev/null 2>&1" );
    system( "$IPT -X $IPOLDCHAIN-DLOG >/dev/null 2>&1" );

    $IPOLDCHAIN = $IPNEWCHAIN;

    return success if( running );

    return failure;
}

sub stop {
    return 1 if( !running );

    print "Removing blocked countries IP filter";

    delchainref( $IHOOK, "$IPOLDCHAIN-I" );
    delchainref( $OHOOK, "$IPOLDCHAIN-O" );
    delchainref( $FHOOK, "$IPOLDCHAIN-O" );

    delsubchains( "$IPOLDCHAIN-I" );
    delsubchains( "$IPOLDCHAIN-O" );

    foreach my $pchain ( @genlist ) {
        system( "$IPT -F $IPOLDCHAIN-$pchain" );
        system( "$IPT -X $IPOLDCHAIN-$pchain" );
    }

    system( "$IPT -F $IPOLDCHAIN-DLOG" );
    system( "$IPT -X $IPOLDCHAIN-DLOG" );
    if( !running ) {
        success;
        return 1;
    }
    failure;
    return 0;
}

sub restart {
    # Don't stop since start will keep the current table alive until
    # the new one is active.
    return start();
}

# List intercepted IPs for today
# This can be run in a cron job just before midnight to get a list of
# IPs to report.  Or, you can use -days n to get the last n days worth
# of intercepts
# Only works if logging is on

sub intercepts {
    my( $fh, %ips );


    $days ||= 1;

    my $start = time() - ( $days * 24*60*60 );
    $host ||= Net::Domain::hostname();

    foreach my $logfile (glob $LOG) {
        my $lh = IO::Uncompress::Gunzip->new( $logfile, MultiStream => 1, Transparent => 1 );
        unless( $lh ) {
            print "Skipping system log file: $IO::Uncompress::Gunzip::GunzipError\n";
            next;
        }
        my $sl = Parse::Syslog->new( $lh, arrayref => 1 );

        # Record # intercepts for each ip => protocol => port

        while( my $l = $sl->next ) {
            next if( $l->[0] < $start );
            next unless $l->[2] eq $LOGPGM && $l->[1] =~ /$host/i;
            if( $l->[4] =~ /^\Q$LOGPFX\E.*?\bSRC=([0-9.]+).*?\bPROTO=(ICMP)\b.*?\bTYPE=(\d+)/ ) {
                $ips{$1}{lc $2}{$3}++;
            } elsif( $l->[4] =~ /^\Q$LOGPFX\E.*?\bSRC=([0-9.]+).*?\bPROTO=(\w+).*?\bDPT=(\d+)/ ) {
                $ips{$1}{lc $2}{$3}++;
            }
        }

        close $lh;
    }

    return 0 unless %ips;

    # List each intercepted IP, its country, the protocols, ports and number of packets for each

    print "Intercepts by host IP:\n";

    my( %ccip, %ccn );
    foreach (glob "$ZONEDIR/*.zone") {
        /$ZONEDIR\/(.*).zone/;
        my $cc = $1;
        next unless( defined code2country( $cc ) ); # Skip undocumented zone files
        open( my $ifh, '<', $_ ) or next;
        while( <$ifh> ) {
            s/\s*#.*$//;
            next unless( length );
            push @{$ccip{$cc}}, NetAddr::IP->new( $_ );
        }
        close $ifh;
    }

    for my $ip (sort map {NetAddr::IP->new($_)} keys %ips) {
        my $ccn;
      CCSEARCH:
        foreach my $cc (keys %ccip) {
            foreach my $cip (@{$ccip{$cc}}) {
                if( $cip->contains($ip) ) {
                    print "$cc: ";
                    $ccn = $cc;
                    last CCSEARCH;
                }
            }
        }
        unless( $ccn ) {  # Possible if we've stopped blocking a country but have old log entries
            $ccn = '??';
            print '??: ';
        }
        print $ip->addr;
        my @plist = sort keys %{$ips{$ip->addr}}; # Protocol
        for my $p (@plist) {
            my @rlist = sort keys %{$ips{$ip->addr}{$p}}; # Ports
            print ' ', join( ' ', map { my $n = $ips{$ip->addr}{$p}{$_}; $ccn{$ccn} += $n; "$p-$_($n)" } @rlist );
        }
        print "\n";
    }

    print "Intercepts by country:\n";
    for my $cc (sort {$ccn{$b} <=> $ccn{$a} } keys %ccn) {
        my $cn = code2country($cc);
        if( defined $cn ) {
            $cn = "$cc ($cn)";
        } else {
            $cn = $cc;
        }
        printf "%10u %s\n", $ccn{$cc}, $cn;
    }
    return 1;
}

if( $cmd eq 'start' ) {
    exit !start();
}
if( $cmd eq 'stop' ) {
    exit !stop();
}
if( $cmd eq 'restart' ) {
    exit !restart();
}
if( $cmd eq 'condrestart' ) {
    exit !(running && restart());
}
if( $cmd eq 'status' ) {
    exit !status();
}
if( $cmd eq 'list' ) {
    exit !list();
}
if( $cmd eq 'intercepts' ) {
    exit !intercepts();
}
if( $cmd eq 'help' ) {
    Usage();
    exit;
}
print "Usage: $prog (start|stop|restart|condrestart|status|list|intercepts|help)\n";
exit 1;