you-dont-need-pihole/make-block.pl

#!/usr/bin/perl

###############################################################################
# You Don't Need Pi-hole
# Network-wide DNS blocking without extra hardware.
#
# Project URL: https://codeberg.org/h3xx/you-dont-need-pihole
#
# License GPLv3: GNU GPL version 3.0 (https://www.gnu.org/licenses/gpl-3.0.html)
# with Commons Clause 1.0 (https://commonsclause.com/).
# This is free software: you are free to change and redistribute it.
# There is NO WARRANTY, to the extent permitted by law.
# You may NOT use this software for commercial purposes.
###############################################################################

use 5.012;
use warnings;

use Getopt::Long qw/ GetOptions :config bundling no_getopt_compat no_ignore_case /;
use FindBin qw//;

my %domains;
my $dupes = 0;
my $skip = 0;
my $removed_allowed = 0;
sub add_domain_list {
    my $file = shift;
    foreach my $line (read_stripped($file)) {
        my $domain = lc $line;
        if (defined $domains{$domain}) {
            ++$dupes;
        }
        $domains{$domain} = 1;
    }
}

sub add_host_file {
    my $file = shift;
    foreach my $line (read_stripped($file)) {
        my @parts = split /\s+/, $line;
        die "Malformed line in $file: $line; @parts"
            unless @parts > 1;
        if (lc $parts[0] eq lc $parts[1]) {
            ++$skip;
            next;
        }
        unless (lc $parts[0] eq '0.0.0.0') {
            ++$skip;
            next;
        }
        my $domain = lc $parts[1];
        if (defined $domains{$domain}) {
            ++$dupes;
        }
        $domains{$domain} = 1;
    }
}

sub read_stripped {
    my $file = shift;

    open my $fni, '<', $file
        or die "Failed to open file $file for reading: $!";

    map {
        chomp;
        # Strip whitespace and comments
        s/^\s+|\s+$|\s*#.*$//;
        $_ || ()
    } <$fni>;
}

MAIN: {
    my $out;
    my $block_ip = '0.0.0.0 ::';
    my $workdir = $FindBin::RealBin;

    unless (GetOptions(
        'out|O=s' => \$out,
        'block-ip|i=s' => \$block_ip,
    )) {
        exit 2;
    }

    my @domain_lists = glob "$workdir/lists/*.domains";
    my @hosts_lists = glob "$workdir/lists/*.hosts";
    my @allow_lists = glob "$workdir/allowlists/*.domains";

    foreach my $listfile (@domain_lists) {
        add_domain_list($listfile);
    }
    foreach my $hostfile (@hosts_lists) {
        add_host_file($hostfile);
    }

    # Apply allowlists
    my @allow_domains;
    foreach my $allowlist (@allow_lists) {
        push @allow_domains, read_stripped($allowlist);
    }
    my $before = %domains;
    delete %domains{@allow_domains};
    # Count number removed
    $removed_allowed = $before - %domains;

    my $written = 0;
    my $fho = \*STDOUT;
    if (defined $out && length $out) {
        open $fho, '>', $out
            or die "Failed to open file $out for writing: $!";
    }
    my @block_ip = sort split /\s+/, $block_ip;
    print $fho map {
        ++$written;
        my $domain = $_;
        map {
            "$_ $domain\n"
        } @block_ip;
    } sort keys %domains;

    printf STDERR "%d domains written to %s from\n", $written, $out // 'STDOUT';
    printf STDERR " - %d .domains files\n", (scalar @domain_lists);
    printf STDERR " - %d .hosts files\n", (scalar @hosts_lists);
    if ($dupes) {
        say STDERR "($dupes duplicates)";
    }
    if ($removed_allowed) {
        say STDERR "($removed_allowed domains removed via allowlist)";
    }
    if ($skip) {
        say STDERR "($skip skipped)";
    }
}