1 #! /usr/bin/perl

     2 use 5.010;

     3 use strict;

     4 use warnings;

     5 use File::Temp;

     6 use Smart::Comments;

     7 use Digest::SHA qw(sha512_hex);

     8 use Getopt::Long;

     9 use Pod::Usage;

    10 

    11 sub parse {

    12     my $data = join '', @_;

    13     my @lines = split /\n/, $data;

    14 

    15     my @zone;

    16     my ($origin, $ttl, $last_label, $soa_seen);

    17 

    18     foreach (@lines) {

    19         s{;.*$}{};

    20         given ($_) {

    21             when (m{^\s*$})                { next }

    22             when (m{^\s*\$ORIGIN\s+(\S+)}) { $origin = $1 }

    23             when (m{^\s*\$TTL\s+(\S+)})    { $ttl = $1 }

    24             when (

    25                 m{^(?<label>\S+)?

    26 		    \s+(?<ttl>\d[\dwdmhs]*(?=\s+))?

    27 		    \s+(?:(?:IN|ANY)\s+)?(?<rrtype>[a-z]\S*(?=\s+))

    28 		    \s+(?<data>.*)

    29 		  }ix

    30               )

    31             {

    32                 my %rrset = (

    33                     label => $last_label =

    34                       defined $+{label}

    35                     ? $+{label} eq '@'

    36                           ? $origin

    37                           : $+{label}

    38                     : $last_label,

    39                       ttl => h2ttl($+{ttl} // $ttl),

    40                       rrtype => uc $+{rrtype},

    41                       data   => $+{data},

    42                 );

    43 

    44                 if ($rrset{rrtype} eq 'SOA') {

    45                     next if $soa_seen;

    46                     $soa_seen = 1;

    47                 }

    48 

    49                 # label ergänzen, wenn nicht FQDN

    50                 $rrset{label} .= ".$origin"

    51                   unless substr($rrset{label}, -1) eq '.';

    52 

    53                 given ($rrset{rrtype}) {

    54 

    55                     # origin steht im SOA

    56                     when ('SOA') {

    57                         $origin = $rrset{label};

    58 

    59                         # fix the nameserver name

    60                         $rrset{data} =~ s{^(\S+[^.])(?=\s)}{$1.$origin};

    61 

    62                         # fix the hostmaster address

    63                         $rrset{data} =~ s{^\S+\s+\K(\S+[^.])(?=\s)}{$1.$origin};

    64                     }

    65 

    66                     # bei einigen RRs müssen wir die Daten korrigieren

    67                     when ([qw/MX NS PTR/]) {

    68                         $rrset{data} .= ".$origin"

    69                           unless substr($rrset{data}, -1) eq '.';

    70                     }

    71                 }

    72                 my $id = sha512_hex(sort %rrset);

    73                 push @zone, { id => $id, rrset => \%rrset };

    74             }

    75         }

    76     }

    77 

    78     # list of {

    79     #	id => $id,

    80     #	rrset => { label => …, ttl => …, rrtype => …, data => … }

    81     # }

    82     return @zone;

    83 }

    84 

    85 sub ttl2h {

    86     my $seconds = shift;

    87     my @out;

    88     my @units = ([w => 604800], [d => 86400], [h => 3600], [m => 60], [s => 1]);

    89 

    90     foreach (@units) {

    91         my $x = int($seconds / $_->[1]);

    92         push @out, "$x$_->[0]" if $x;

    93         $seconds %= $_->[1] or last;

    94     }

    95 

    96     return join '', @out;

    97 }

    98 

    99 sub h2ttl {

   100     my $ttl = shift;

   101     my $out;

   102     my %factor = (

   103         w => 604800,

   104         d => 86400,

   105         h => 3600,

   106         m => 60,

   107         s => 1,

   108     );

   109 

   110     while ($ttl =~ m{(\d+)([wdhms])}g) {

   111         $out += $1 * $factor{$2};

   112     }

   113 

   114     return $out // $ttl;

   115 }

   116 

   117 sub nice {

   118 

   119     # get a list of { id => $id, rrset => \%rrset }

   120     my @zone =

   121       sort {

   122         length $a->{label} <=> length $b->{label}

   123           or $a->{label}

   124           cmp $b->{label}

   125       } map { $_->{rrset} } @_;

   126 

   127     my @out;

   128     my $origin = (grep { $_->{rrtype} eq 'SOA' } @zone)[0]->{label};

   129     my $ttl    = (grep { $_->{rrtype} eq 'SOA' } @zone)[0]->{ttl};

   130     my $l1 = (sort map { index $_->{label}, '.' } @zone)[-1];

   131     my $l2 = (sort map { length $_->{rrtype} } @zone)[-1];

   132     push @out, "\$ORIGIN $origin", "\$TTL " . ttl2h($ttl);

   133 

   134     my $print = sub {

   135         my %r = %{ +shift };

   136         state $last_label;

   137 

   138         $r{label} = '@' if $r{label} eq $origin;

   139         $r{label} =~ s{\.\Q$origin\E$}{};

   140         $r{data} =~ s{\.\Q$origin\E$}{} if $r{rrtype} ~~ [qw(MX SOA PTR)];

   141         $r{ttl} = $r{ttl} == $ttl ? '' : ttl2h($r{ttl});

   142         $r{label} = do {

   143             if (defined $last_label and $r{label} eq $last_label) { '' }

   144             else { $last_label = $r{label} }

   145         };

   146 

   147         return sprintf '%-*s %6s %-*s    %s',

   148           $l1 => $r{label},

   149           $r{ttl},

   150           $l2 => $r{rrtype},

   151           $r{data};

   152     };

   153     push @out, $print->($_) foreach @zone;

   154     return join "\n", @out;

   155 }

   156 

   157 sub delta {

   158     my ($zone1, $zone2) = @_;

   159     my %zone1 = map { $_->{id}, $_->{rrset} } @$zone1;

   160     my %zone2 = map { $_->{id}, $_->{rrset} } @$zone2;

   161     my @keys1 = keys %zone1;

   162     my @keys2 = keys %zone2;

   163     delete @zone1{@keys2};

   164     delete @zone2{@keys1};

   165     say 'update add ', join ' ' => @{$_}{qw/label ttl rrtype data/}

   166       foreach values %zone2;

   167     say 'update delete ', join ' ' => @{$_}{qw/label ttl rrtype data/}

   168       foreach values %zone1;

   169     exit;

   170 }

   171 

   172 sub main {

   173     my %o = (

   174         key    => undef,

   175         server => undef,

   176     );

   177 

   178     GetOptions(

   179         'k|key=s'    => \$o{key},

   180         's|server=s' => \$o{server},

   181       )

   182       && @ARGV == 1

   183       or pod2usage();

   184 

   185     my @dig = (

   186         dig => 'AXFR',

   187         defined $o{key} ? (-k => $o{key}) : (),

   188         defined $o{server} ? ("\@$o{server}") : (),

   189         $ARGV[0]

   190     );

   191 

   192     my @zone1 = grep {

   193         not $_->{rrset}{rrtype} ~~

   194           [qw(RRSIG NSEC3 NSEC3PARAM NSEC DNSKEY TSIG)]

   195     } parse(`@dig`);

   196 

   197     my $tmp = File::Temp->new();

   198     $tmp->print(nice @zone1);

   199     $tmp->flush();

   200     system $ENV{EDITOR} // 'vi' => $tmp->filename;

   201     $tmp->seek(0, 0);

   202     my @zone2 = parse(<$tmp>);

   203     delta(\@zone1, \@zone2);

   204     exit;

   205 }

   206 

   207 exit main(@ARGV) if not caller;

   208 

   209 __END__

   210 

   211 =head1 NAME

   212 

   213  vidns -- editor for dynamically maintained zones

   214 

   215 =head1 SYNOPSIS

   216 

   217  vidns [-k key] [-s server] <zone>

   218 

   219 =head1 DESCRIPTION

   220 

   221 =head1 PREREQUISITES

   222 

   223 We need some tools to be installed:

   224 

   225 =over

   226 

   227 =item B<dig>

   228 

   229 The domain information grabber is used for the zone transfer currently.

   230 

   231 =item B<nsupdate>

   232 

   233 The nsupdate tool is used to send the updates back to the server.

   234 

   235 =back

   236 

   237 =cut