spf-dkim-dmarc-demo/dns/web-api/lib/Email/SpoofingDemo/DNS/ZoneFile.pm

package Email::SpoofingDemo::DNS::ZoneFile;

use strict;
use warnings;
use utf8;
use v5.10;

use Exporter qw(import);

use File::Slurp;
use Try::Tiny;

our @EXPORT_OK = qw(get_txt get_zone_file import_zone_file remove_txt set_txt
                    zone_file_path);

sub safe_system {
    my @argv = @_;
    my $retval = system @argv;
    die $! if ($retval == -1);
    if ($retval != 0) {
        my $status = $retval >> 8;
        die join(" ", @argv) . " exited with status $status\n";
    };
    return 1;
}

sub is_dynamic_zone {
    my ($zone, $dynamic_zones) = @_;

    return grep { $_ eq $zone } @$dynamic_zones;
}

sub rndc_freeze {
    my ($zone) = @_;

    safe_system('rndc', 'freeze', $zone);
}

sub rndc_thaw {
    my ($zone) = @_;

    safe_system('rndc', 'thaw', $zone);
}

sub rndc_reload {
    my ($zone) = @_;

    safe_system('rndc', 'reload', $zone);
}

sub encode_txt {
    my ($text) = @_;

    my $chunk_length = 255;
    my $text_bytes = $text;
    utf8::encode($text_bytes);

    my @parts;
    for (my $i = 0; $i < length($text_bytes); $i += $chunk_length) {
        my $part = substr($text_bytes, $i, 255);
        $part =~ s/[\x00-\x1f"\x7f-\xff]/sprintf('\\%03d', ord($0))/eg;
        push @parts, qq{"$part"};
    }

    return join(" ", @parts);
}

sub relative_to_absolute {
    my ($zone, $relative_owner) = @_;

    if ($relative_owner eq '') {
        return $zone;
    }
    else {
        return "$relative_owner.$zone";
    }
}

sub nsupdate {
    my ($zone, @instructions) = @_;

    open(my $pipe, '|-', 'nsupdate') or die "Can’t fork: $!";
    say $pipe qq{zone $zone};
    say $pipe $_ foreach (@instructions);
    close($pipe);

    return (($? >> 8) == 0);
}

sub get_txt {
    my ($zone, $relative_owner, $filter, $sublabels_ok) = @_;

    $filter //= qr{.*};
    $sublabels_ok //= 0;

    my @dig_opts = qw(+nottlid +noclass +norecurse +noall +answer @127.0.0.1);

    my $owner_suffix = relative_to_absolute($zone, $relative_owner);
    my $qname = ($sublabels_ok ? $zone : $owner_suffix);
    my $qtype = ($sublabels_ok ? 'AXFR' : 'TXT');
    my $owner_match_re = ($sublabels_ok ? qr/^([^.]+\.)*$owner_suffix\.$/i : qr/^$qname\.$/i);

    my @result;

    open(my $pipe, '-|', 'dig', @dig_opts, $qtype, $qname) or die "Can’t fork: $!";

    while (<$pipe>) {
        chomp;

        next if /^;/;
        next if /^\s*$/;

        my ($owner, $type, $data) = split(" ", $_, 3);

        unless ($type eq 'TXT') {
            next;
        }
        unless ($owner =~ $owner_match_re) {
            next;
        }

        my $concat_data = ($data =~ s/"((?:[^\\"]|\\"|\\\d{3})*)"\s*/$1/gr);
        unless ($concat_data =~ $filter) {
            next;
        }

        push @result, { owner => ($owner =~ s/\.$//r), txt => $concat_data };
    }

    close($pipe);

    if (wantarray) {
        return @result;
    }
    else {
        return $result[0];
    }
}

sub set_txt {
    my ($zone, $relative_owner, $txt) = @_;
    my $owner = relative_to_absolute($zone, $relative_owner);
    my $txt_encoded = encode_txt($txt);

    nsupdate(
        $zone,
        "update delete $owner 0 IN TXT",
        "update add $owner IN TXT $txt_encoded",
        "send");
}

sub remove_txt {
    my ($zone, $relative_owner) = @_;
    my $owner = relative_to_absolute($zone, $relative_owner);

    nsupdate(
        $zone,
        "update delete $owner 0 IN TXT",
        "send");
}

sub check_zone {
    my ($zone_contents, $origin) = @_;

    open(my $pipe, '|-', 'named-checkzone', $origin, '-') or die "Can’t fork: $!";
    print $pipe $zone_contents;
    close($pipe);

    return (($? >> 8) == 0);
}

sub zone_file_path {
    my ($zone, $base_dir, $force) = @_;

    my @components = reverse(split(/\./, $zone));
    my $path = $base_dir . '/' . (join('/', @components)) . ".zone";

    if (not -f $path and not $force) {
        return undef;
    }
    return $path;
}

sub get_zone_file {
    my ($zone, $base_dir, $dynamic_zones) = @_;

    my $path = zone_file_path($zone, $base_dir);
    return undef if not defined $path;

    rndc_freeze($zone) if is_dynamic_zone($zone, $dynamic_zones);

    my $contents;
    try {
        $contents = read_file($path);
    }
    finally {
        rndc_thaw($zone) if is_dynamic_zone($zone, $dynamic_zones);
    };

    return $contents;
}

sub import_zone_file {
    my ($zone, $base_dir, $contents, $dynamic_zones) = @_;

    if ($contents =~ /^\s*$/) {
        warn "Zone to import is empty";
        return undef;
    }

    my $path = zone_file_path($zone, $base_dir);
    if (not defined $path) {
        warn "No zone file for $zone in $base_dir";
        return undef;
    }

    if (not check_zone($contents, $zone)) {
        warn "Zone file contents do not pass syntax check";
        return undef;
    }

    rndc_freeze($zone) if is_dynamic_zone($zone, $dynamic_zones);

    try {
        write_file($path, $contents);
        rndc_reload($zone) unless is_dynamic_zone($zone, $dynamic_zones);
    }
    catch {
        die $_;
    }
    finally {
        rndc_thaw($zone) if is_dynamic_zone($zone, $dynamic_zones);
    };

    return 1;
}

1;