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

#
# SPDX-FileCopyrightText: 2023 Afnic
#
# SPDX-License-Identifier: GPL-3.0-or-later
#

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

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

use Exporter qw(import);
use IPC::Open2;

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 parse_named_checkzone_output {
    my ($line, $previous_messages) = @_;

    chomp $line;

    if ($line =~ /^OK$/) {
        # On regarde déjà le code de sortie de la commande named-checkzone,
        # donc un message "OK" n’ajoute aucune information.
        return undef;
    }
    elsif ($line =~ /^zone [^:]+: (.*)$/) {
        my $msg = $1;

        # Ce pattern accompagne parfois des messages d’erreur précédents, mais
        # pas toujours. On ne conserve ce message que s’il n’y en a pas eu
        # d’autres avant.
        if ($msg =~ /loading from master file \(null\) failed: (.*)$/) {
            my $zone_error = $1;

            if (grep { $_ =~ qr/\Q$zone_error\E$/ } @$previous_messages) {
                return undef;
            }
            else {
                return $zone_error;
            }
        }

        # Ce pattern accompagne des messages d’erreur précédents,
        # et n’ajoute donc aucune information.
        return undef if ($msg eq 'not loaded due to errors.');

        # Renvoyé en cas de réussite
        return undef if ($msg =~ /loaded serial \d+/);

        # Cas de tout autre message
        return $line;
    }
    elsif ($line =~ /stream-0x[0-9a-f]+/) {
        # named-checkzone préfixe parfois ses messages d’erreur par des noms
        # de fonctions internes. On ne les conserve pas, car ce sont des
        # détails internes pas très user-friendly.
        $line =~ s/^dns_(?:master_load|rdata_fromtext): //;

        # Comme named-checkzone a lu le fichier de zones à travers un pipe,
        # named-checkzone rapporte en guise de nom de fichier un truc opaque
        # pas très user-friendly qu’il vaut mieux supprimer. Mais on conserve
        # bien entendu le numéro de la ligne !
        $line =~ s/stream-0x[0-9a-f]+:(\d+):/Ligne $1:/;
        $line =~ s/stream-0x[0-9a-f]+:\s*//;

        # Est-ce si grave si le fichier ne finit pas par une fin de ligne ?
        return undef if $line =~ /file does not end with newline/;

        return $line;
    }
    else {
        return $line;
    }
}

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

    if ($zone_contents =~ /^\$INCLUDE\s+/ms) {
        return 'failure', ['Refusing to load zone file containing $INCLUDE'];
    }

    my $pid = open2(my $pipe_out, my $pipe_in,
                    'named-checkzone', $origin, '-');

    print $pipe_in $zone_contents;
    close($pipe_in);

    my @messages;
    while (<$pipe_out>)
    {
        chomp;
        my $line = parse_named_checkzone_output($_, \@messages);
        push @messages, $line if defined $line;
    }

    waitpid($pid, 0);
    my $exit_status = ($? >> 8);

    my $outcome;
    if ($exit_status != 0) {
        $outcome = 'failure';
    }
    elsif (scalar @messages) {
        $outcome = 'ok_with_warnings';
    }
    else {
        $outcome = 'ok';
    }

    return ($outcome, \@messages);
}

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*$/) {
        return "failure", ["Zone to import is empty"];
    }

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

    my ($outcome, $messages) = check_zone($contents, $zone);

    if ($outcome ne 'failure') {
        rndc_freeze($zone) if is_dynamic_zone($zone, $dynamic_zones);

        try {
            write_file($path, $contents);
            unless (is_dynamic_zone($zone, $dynamic_zones)) {
                rndc_reload($zone);
            }
        }
        catch {
            return 'failure', [$_];
        }
        finally {
            if (is_dynamic_zone($zone, $dynamic_zones)) {
                rndc_thaw($zone);
            }
        };
    }

    return $outcome, $messages;
}

1;