335 lines
7.9 KiB
Perl
335 lines
7.9 KiB
Perl
#
|
||
# 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;
|