genblock

#!/usr/bin/env perl
# Copyright (c) 2022-2023 Ashlen <eurydice@riseup.net>

# Permission to use, copy, modify, and distribute this software for any
# purpose with or without fee is hereby granted, provided that the above
# copyright notice and this permission notice appear in all copies.

# THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
# WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
# MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
# ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
# WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
# ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
# OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.

use v5.36;
use autodie;
use strict;
use warnings;

use File::Basename qw(fileparse);
use Getopt::Std;
use List::Util qw(first);

if ( $^O eq 'openbsd' ) {
	use OpenBSD::Pledge;
	sub pledge_or_die { pledge(@_) or die "Pledge failed: $!"; }
	pledge_or_die qw(rpath);
}

my $program_name = fileparse $0;

sub usage {
	die <<"EOT";
$program_name extracts unique domains. Useful for generating blocklists.

usage: $program_name [-h] [-t type] [file (optional)] ...

-h: help.

-t: type of format, 'plain' by default.
    'plain' extracts one domain per line and does no other formatting.

    'unbound' formats the domain as 'local-zone: \"[domain]\" always_refuse'

    'rpz' formats the domain as '[domain] CNAME .', and then copies that to a
    wildcard entry. It also reduces domains to avoid unnecessary duplication.

$program_name can read from STDIN, or one or more files.
EOT
}

# For more details, see:
# RFC1123 section 2-1
# RFC1034 section 3-1
# RFC2181 section 11
sub is_domain {
	my $potential_domain = shift or return;

	if (
		$potential_domain =~ /
	\b

	# BEGIN LEAF GROUP
	(

	# Lookahead ensures that the next domain leaf includes 1-63 allowed
	# characters
	(?= [a-z 0-9 -_]{1,63} \.)

	# Matches every leaf up to the top-level domain
	#
	# Optional hyphen and underscore group ensures that they can only
	# occur between the first and last character of a domain leaf
	[a-z 0-9]+
	([-_]+ [a-z 0-9]+)*

	# END LEAF GROUP, ONE OR MORE
	\.)+

	# TOP-LEVEL DOMAIN GROUP
	# Must be a punycode TLD _or_ a regular TLD
	(
	(xn-- [a-z 0-9]{2,59}) # punycode TLD
	|
	[a-z]{2,63} # regular TLD
	)

	\b
	/paaxxn
		)
	{
		return ${^MATCH};
	}
	return;
}

# Given a hash reference, we "reduce" fully-qualified domains by
# starting with their root domain.
#
# If the root domain is a key in the hash, delete the fully-qualified
# domain (a wildcard will match it).
#
# Otherwise, progressively add subdomains back in, moving right to left,
# until we either discover a matching key or reach the end.
#
# Example:
# advertising.bad-actor.com
# bad-actor.com
#
# *.bad-actor.com will match advertising.bad-actor.com as well.
# Therefore, we can delete advertising.bad-actor.com from the hash.
sub reduce_domains {
	my $hashref = shift or return;
	my %redundant_domains;

	while ( my $domain = each %$hashref ) {
		## Start with the root domain.
		my $index = rindex $domain, '.', rindex( $domain, '.' ) - 1;

		while ( $index != -1 ) {
			my $leaf = substr $domain, $index + 1;

			if ( defined $hashref->{$leaf} ) {
				delete $hashref->{$domain};
				$redundant_domains{$domain} = $leaf;
				last;
			}

			$index = rindex $domain, '.', $index - 1;
		}
	}
	wantarray
		? return %redundant_domains
		: return \%redundant_domains;
}

sub unique_domains {
	my %unique_domains;

	while ( <<>> ) {
		chomp;

		# Don't process commented or blank lines.
		next if /\A \s* (\z|\#)/aaxxn;

		# Get rid of these common leading IP addresses in hosts(5)
		# formatted blocklists.
		#
		# Types of entries that this addresses:
		# 0.0.0.0alfa-bitcoin.com
		s/\A \s* (127\.0\.0\.1|0\.0\.0\.0) \s*//aaxxn;

		# Lines with these IP addresses at the tail end of a word
		# (likely caused by maintainer typos) can't be trusted. Messing
		# with them is likely to mangle the line and give a bogus
		# result; accepting them is also likely to give a bogus result.
		#
		# Here are two examples of lines that match:
		# zy16eoat1w.com0.0.0.0 102.112.2o7.net
		# vungle.com0.0.0.0adminer.com
		next if /\B (127\.0\.0\.1|0\.0\.0\.0)/aaxxn;

		# Lowercase vs uppercase doesn't matter for DNS.
		$_ = lc $_;

		my $domain = do {
			is_domain $_ or next;
		};

		$unique_domains{$domain}++;
	}
	wantarray
		? return %unique_domains
		: return \%unique_domains;
}

our $opt_h;
our $opt_t = 'plain';

getopts 'ht:';
usage if defined $opt_h;

my @formats = qw(plain unbound rpz);
first { $opt_t eq $_ } @formats or die "$opt_t is not a valid type.\n";

my %domain_appearances = &unique_domains
	or die "Unable to extract any domains from input.\n";

if ( $opt_t eq 'plain' ) {
	print map { "$_\n" } sort keys %domain_appearances;
}
elsif ( $opt_t eq 'unbound' ) {
	print map { "local-zone: \"$_\" always_refuse\n" }
		sort keys %domain_appearances;
}
elsif ( $opt_t eq 'rpz' ) {
	&reduce_domains( \%domain_appearances );

	#<<<
	print map {
		"$_ CNAME .\n"
		. "*.$_ CNAME .\n"
	} sort keys %domain_appearances;
	#>>>
}