parse_cncpo

#!/usr/bin/perl
# vim: shiftwidth=4 tabstop=4
#
# Copyright 2014 by Seeweb s.r.l.
# Written by Marco d'Itri <md@Linux.IT>
#
# 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 of the License, or
# (at your option) any later version.

use warnings;
use strict;
use autodie;

use List::MoreUtils qw(uniq);
use File::Slurp;
use Text::CSV 0.32;

# Set this to true if your domain censorship method automatically censors
# all the subdomains of a censored domain.
my $Remove_Subdomains = 1;

##############################################################################
my $RE_ipaddr = qr/
	(?: (?: 25[0-5]|2[0-4][0-9]|[01]?[0-9][0-9]? ) \. ){3}
		(?: 25[0-5]|2[0-4][0-9]|[01]?[0-9][0-9]? )
/x;
my $RE_domain = qr/[a-z0-9\.-]+\.[a-z]+/;

die "Usage: $0 CSV_INPUT DOMAINS_OUTPUT IPS_OUTPUT\n"
	if @ARGV != 3;

my $list = parse_csv_file($ARGV[0]);
#use Data::Dumper; print Data::Dumper->Dumpxs([$list], ['list']);

die "FATAL: lista vuota" if not $list or not @$list;

my $lists = parse_cncpo_list($list);

die "Censoring URLs is not supported!\n"
	if $lists->{urls} and @{ $lists->{urls} };

die "No domains found!\n"
	if not $lists->{domains} or not @{ $lists->{domains} };

remove_subdomains($lists) if $Remove_Subdomains;

write_file($ARGV[1], { atomic => 1 },
	map { "$_\n" } sort @{ $lists->{domains} });
write_file($ARGV[2], { atomic => 1 },
	map { "$_\n" } sort @{ $lists->{ips} });

exit 0;

##############################################################################
sub parse_cncpo_list {
	my ($list) = @_;
	my (@domains, @ips, @urls);

	my ($number, $timestamp, $rest) = @{ shift @$list };
	die "Invalid blacklist header!\n" if $rest;
	die "Missing blacklist serial number!\n"
		if not $number or $number !~ /^\d+$/;
	die "Missing timestamp!\n"
		if not $timestamp or $timestamp !~ /^\d+$/;
		
	foreach my $row (@$list) {
		next if @$row == 1;				# skip empty lines in the CSV
		my ($url, $domain, $ipurl, $ip) = @$row;

		$url = lc $url;
		$domain = lc $domain;

		if ($url) {
			if ($url !~ m#^(?:https?://)?($RE_domain)#o) {
				warn "WARNING: campo 1 non valido per il record $url";
				next;
			}
			my $xdomain = $1;
			if (not $domain) {
				$domain = $xdomain;
				warn "WARNING: campo 2 mancante per il record $url";
			} elsif ($domain ne $xdomain) {
				warn "WARNING: campi 1 e 2 non corrispondenti per il"
					. " record $url";
				next;
			}
		} elsif ($domain) {
			warn "WARNING: campo 1 mancante per il record $domain";
		}

		if ($ipurl) {
			$RE_ipaddr= qr/[0-9\.]+/;
			if ($ipurl !~ m#^(?:https?://)?(${RE_ipaddr})#o) {
			#if ($ipurl !~ m#(${RE_ipaddr})#o) {
				warn "WARNING: campo 3 non valido per il record $ipurl";
				next;
			}
			$ipurl =~ m#^(?:https?://)?(${RE_ipaddr})(?:/.*)?$#o; #
			my $embeddedip = $1;
			if (not $ip) {
				$ip = $embeddedip;
				warn "WARNING: campo 3 mancante per il record $ipurl";
			} elsif ($ip ne $embeddedip) {
				warn "WARNING: campi 3 e 4 non corrispondenti per il"
					. " record $ipurl";
				next;
			}
		} elsif ($ip) {
			warn "WARNING: campo 3 mancante per il record $ip";
		}

		if ($domain) {
			if ($domain !~ /^$RE_domain$/o) {
				warn "WARNING: dominio non valido per il record $domain";
				next;
			}
			push(@domains, $domain);
		} elsif ($ip) {
			if ($ip !~ /^$RE_ipaddr$/o) {
				warn "WARNING: IP non valido per il record $ip";
				next;
			}
			push(@ips, $ip);
		} else {
			warn "WARNING: record vuoto";
		}

	} # foreach

	return {
		number	=> $number + 0,
		date	=> $timestamp,
		ips		=> [ uniq @ips ],
		domains	=> [ uniq @domains ],
		urls	=> [ uniq @urls ],
	};
}

##############################################################################
sub parse_csv_file {
	my ($file) = @_;

	open(my $fh, $file);

	my $csv = Text::CSV->new({
		binary		=> 1,
		sep_char	=> ';',
	});

	my @list;
	while (my $row = $csv->getline($fh)) {
		foreach (@$row) {				# sanitize each field
			s/[\r\n\t]//g;
			s/\s+$//;
		}
		push(@list, $row);
	}

	close $fh;

	if (not $csv->eof) {
		my ($code, $str, $pos) = $csv->error_diag;
		die "CSV ERROR: $code - $str at line $pos!\n"
	}

	return \@list;
}

##############################################################################
sub remove_subdomains {
	my ($l) = @_;
	return if not $l or not $l->{domains};

	my $list = $l->{domains};

	my %domains = map { $_ => undef } @$list;

	for (my $i = 0; $i < @$list; $i++) {
		my $domain = $list->[$i];
		# remove each leading component of the domain and check if the new
		# resulting domain is in our list
		while ($domain =~ s/^.+?\.(.+\..+)$/$1/) {
			delete $list->[$i] if exists $domains{$domain};
		}
	}

	# remove the deleted domains from the list
	$l->{domains} = [ grep { defined $_ } @{ $l->{domains} } ];
}