Éditeur de zone : meilleurs messages de diagnostic

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.

console/Dockerfile

@@ -71,6 +71,7 @@ RUN apk add perl-io-socket-ssl perl-lwp-protocol-https
 
 RUN cpanm -n -v \
     Dancer2 \
+    Dancer2::Plugin::Deferred \
     REST::Client \
     Module::Pluggable::Object
 

console/web-api/lib/Email/SpoofingDemo/Web.pm

@@ -1,5 +1,6 @@
 package Email::SpoofingDemo::Web;
 use Dancer2;
+use Dancer2::Plugin::Deferred;
 
 use JSON;
 use REST::Client;
@@ -43,13 +44,13 @@ get '/' => sub {
 
 get '/dns/zone-edit/:zone' => sub {
     my $zone = route_parameters->get('zone');
-    if (defined $zone and not (grep { $_ eq $zone } @{config->{'editable_zones'}})) {
+    if (not (grep { $_ eq $zone } @{config->{'editable_zones'}})) {
         pass;
     }
 
-    my $zone_contents;
+    my $zone_contents = deferred 'zone_contents';
 
-    if (defined $zone) {
+    if (not defined $zone_contents) {
         my ($response, $status) = call_api(GET => 'dns', "/zone/${zone}/file");
         $zone_contents = $response->{contents};
     }
@@ -68,10 +69,18 @@ post '/dns/zone-edit/:zone' => sub {
     }
 
     my $contents = body_parameters->{'zone-contents'};
-    my (undef, $status) = call_api(PUT => 'dns', "/zone/${zone}/file", { contents => $contents });
+    my ($data, $status) = call_api(PUT => 'dns', "/zone/${zone}/file", { contents => $contents });
-    my $success = ($status eq '200') ? 'success' : 'failure';
 
-    redirect "/dns/zone-edit/$zone?success=$success", 303;
+    if ($status ne '200') {
+        $data = decode_json($data);
+    }
+    deferred status => {
+        outcome => $data->{outcome},
+        messages => $data->{messages},
+    };
+    deferred zone_contents => $data->{contents};
+
+    redirect "/dns/zone-edit/$zone", 303;
 };
 
 get '/sender/dkim-keys' => sub {

console/web-api/views/dns/zone-edit.tt

@@ -1,4 +1,36 @@
 <div class="container">
+  [% IF deferred.status %]
+    [%
+       outcome_map = {
+           ok => {
+               color => 'success',
+               message => 'Les modifications ont été prises en compte.'
+           },
+           ok_with_warnings => {
+               color => 'warning',
+               message => 'Les modifications ont été prises en compte, mais avec les réserves suivantes :'
+           },
+           failure => {
+               color => 'danger',
+               message => 'La zone contient des erreurs ; les modifications n’ont pas été prises en compte.'
+           }
+       }
+
+       outcome_info = outcome_map.item(deferred.status.outcome)
+    %]
+    <div class="alert alert-[% outcome_info.color %] pb-1">
+      <p>[% outcome_info.message %]</p>
+      [% IF deferred.status.messages.size > 1 %]
+        <ul>
+          [% FOR m IN deferred.status.messages %]
+          <li>[% m | html %]</li>
+          [% END %]
+        </ul>
+      [% ELSIF deferred.status.messages.size == 1 %]
+        <p>[% deferred.status.messages.first | html %]</p>
+      [% END %]
+    </div>
+  [% END %]
   <div class="row mt-3 mb-4">
     <main class="col">
       <form id="edit-form" method="POST">

dns/web-api/lib/Email/SpoofingDemo/API/DNS.pm

@@ -30,19 +30,34 @@ prefix '/zone/:zone' => sub {
         my $zone = route_parameters->get('zone');
         my $contents = body_parameters->get("contents");
 
+        # Convertir le fichier de zone aux fins de ligne UNIX et ajouter un
+        # retour chariot final s’il y en a pas déjà un, pour éviter des
+        # erreurs absconses
+        $contents =~ s/\r\n/\n/g;
+        $contents =~ s/\n?$/\n/;
+
+        my @lines = split(/\r?\n/, $contents);
+
         if (not defined $contents) {
             status 'bad_request';
-            return "missing zone file contents";
+            return {
+                outcome => 'failure',
+                messages => ['La zone semble être vide.'],
+                contents => $contents
+            };
         }
 
-        my $result = import_zone_file($zone, $base_dir, $contents, $dynamic_zones);
+        my ($outcome, $messages) = import_zone_file($zone, $base_dir, $contents, $dynamic_zones);
-        if ($result) {
+
-            return;
+        if ($outcome eq 'failure') {
-        }
-        else {
             status 'bad_request';
-            return "bad zone file";
         }
+
+        return {
+            outcome => $outcome,
+            messages => $messages,
+            contents => $contents
+        };
     };
 
     get '/spf' => sub {

dns/web-api/lib/Email/SpoofingDemo/DNS/ZoneFile.pm

@@ -7,6 +7,7 @@ use utf8;
 use v5.10;
 
 use Exporter qw(import);
+use IPC::Open2;
 
 use File::Slurp;
 use Try::Tiny;
@@ -160,14 +161,102 @@ sub remove_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) = @_;
 
-    open(my $pipe, '|-', 'named-checkzone', $origin, '-') or die "Can’t fork: $!";
+    if ($zone_contents =~ /^\$INCLUDE\s+/ms) {
-    print $pipe $zone_contents;
+        return 'failure', ['Refusing to load zone file containing $INCLUDE'];
-    close($pipe);
+    }
 
-    return (($? >> 8) == 0);
+    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 {
@@ -205,35 +294,36 @@ sub import_zone_file {
     my ($zone, $base_dir, $contents, $dynamic_zones) = @_;
 
     if ($contents =~ /^\s*$/) {
-        warn "Zone to import is empty";
+        return "failure", ["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 "failure", ["No zone file for $zone in $base_dir"];
-        return undef;
     }
 
-    if (not check_zone($contents, $zone)) {
+    my ($outcome, $messages) = check_zone($contents, $zone);
-        warn "Zone file contents do not pass syntax check";
+
-        return undef;
+    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);
+            }
+        };
     }
 
-    rndc_freeze($zone) if is_dynamic_zone($zone, $dynamic_zones);
+    return $outcome, $messages;
-
-    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;