f220e71544
Quand le code appelle named-checkzone pour le contrôle de syntaxe DNS, les messages renvoyés par cet utilitaire de contrôle sont lus et interprétés, puis remontés à l’utilisateur. Ce n’est pas parfait et ça donne une espèce de franglais, mais ça suffira pour la démo et tant qu’on ne laisse pas les élèves manipuler directement les fichiers de zone. Dans le cas contraire, il faudra améliorer cela.
330 lines
7.8 KiB
Perl
330 lines
7.8 KiB
Perl
|
||
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;
|