1 package DNS::Vi;

     2 use 5.0101;

     3 use strict;

     4 use warnings;

     5 use if $ENV{DEBUG} // '' eq 'dnsvi' => 'Smart::Comments';

     6 use Digest::SHA qw(sha512_hex);

     7 use File::Temp;

     8 use Net::DNS;

     9 use Term::ReadKey;

    10 use base 'Exporter';

    11 use if $] >= 5.020, experimental => 'smartmatch';

    12 

    13 our @EXPORT = qw(ttl2h h2ttl parse delta nice edit update show get_key

    14   get_auth_info);

    15 our @EXPORT_OK = ();

    16 

    17 # the sort order for the records of the same label

    18 my %ORDER = map { state $n = 0; $_ => ++$n } qw(SOA NS TXT MX A AAAA SSHFP);

    19 

    20 sub h2ttl(_);

    21 

    22 # input $arg - hash with options

    23 #       $data - a long string with the zone data

    24 sub parse {

    25     my %arg   = %{ pop @_ } if ref $_[-1] eq ref {};

    26     my $data  = shift;

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

    28 

    29     my @zone;

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

    31 

    32     $_ = '';

    33     foreach (@lines) {

    34 	# simplificated comment remover

    35 	# after the comment character no '"' is allowed!

    36 #        s{^\s*;.*$}{};		  # strip comment lines

    37 #	s{\s*;[^"]*$}{};	  # strip trailing comments

    38 

    39 	# see https://regex101.com/r/cG6fK3/2

    40  	s{\s*(?:;)(?:(?:[^"]|"[^"]*")*$)}{};

    41         state $line;

    42         if (my $range = /(.*)\(\s*$/ .. /(.*)\)\s*/) {

    43             $line .= defined $1 ? $1 : $_;

    44             next unless $range =~ /E0$/;

    45         }

    46         if (defined $line) {

    47             $_    = $line;    # accumulated continuation line

    48             $line = undef;

    49         }

    50         s{\s*$}{};            # strip off trailing spaces

    51         given ($_) {

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

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

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

    55             when (

    56                 m{^(?:(?<label>\S+)(?=\s))?

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

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

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

    60 		  }ix

    61               )

    62             {

    63                 my %rrset = (

    64                     label => $last_label =

    65                       defined $+{label}

    66                     ? $+{label} eq '@'

    67                           ? $origin

    68                           : $+{label}

    69                     : $last_label,

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

    71                       rrtype => uc $+{rrtype},

    72                       data   => $+{data},

    73                 );

    74                 next if $rrset{rrtype} ~~ $arg{-skip};

    75 

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

    77                     next if $soa_seen++;

    78                 }

    79 

    80                 # label ergänzen, wenn nicht FQDN

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

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

    83 

    84                 given ($rrset{rrtype}) {

    85 

    86                     # origin steht im SOA

    87                     when ('SOA') {

    88                         $origin = $rrset{label};

    89                         my ($primary, $hostmaster, $serial, $refresh, $retry,

    90                             $expire, $minttl)

    91                           = split ' ', $rrset{data};

    92 

    93                         $_ .= ".$origin" foreach grep !/\.$/ => $primary,

    94                           $hostmaster;

    95 

    96                         $rrset{data} = join ' ',

    97                           $primary, $hostmaster, $serial,

    98                           map { h2ttl } $refresh, $retry, $expire, $minttl;

    99                     }

   100 

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

   102                     when ([qw/CNAME MX NS PTR SOA/]) {

   103                         $rrset{data} =~ s/\@/$origin/g;

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

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

   106                     }

   107                 }

   108                 my $id = sha512_hex(join "\0",

   109                     map { $_ => $rrset{$_} } sort keys %rrset);

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

   111                 ### x: $zone[-1]

   112             }

   113         }

   114     }

   115 

   116     return @zone;

   117 }

   118 

   119 sub ttl2h {

   120     my $seconds = shift;

   121     my @out;

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

   123 

   124     foreach (@units) {

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

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

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

   128     }

   129 

   130     return join '', @out;

   131 }

   132 

   133 sub h2ttl(_) {

   134     my $ttl = shift;

   135     my $out;

   136     my %factor = (

   137         w => 604800,

   138         d => 86400,

   139         h => 3600,

   140         m => 60,

   141         s => 1,

   142     );

   143 

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

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

   146     }

   147 

   148     return $out // $ttl;

   149 }

   150 

   151 sub nice {

   152 

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

   154     # we do a schwartz transformation here

   155     # [ reverse LABEL, RRSET ]

   156     my @zone = map { $_->[1] }

   157       sort {

   158              $a->[0] cmp $b->[0]

   159           or length $a->[1]{label} <=> length $b->[1]{label}

   160           or ($ORDER{ $a->[1]{rrtype} } // 99)

   161           <=> ($ORDER{ $b->[1]{rrtype} } // 99)

   162       }

   163       map { [scalar reverse($_->{label}), $_] } map { $_->{rrset} } @_;

   164 

   165     my @out;

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

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

   168     my $len1 =

   169       (sort { $a <=> $b } map { index $_->{label}, '.' } @zone)[-1];

   170     my $len2 = (sort { $a <=> $b } map { length $_->{rrtype} } @zone)[-1];

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

   172 

   173     my $print = sub {

   174         my %r = %{ +shift };

   175         state $last_label;

   176 

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

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

   179         $r{data} =~ s{\.\Q$origin\E$}{}

   180           if $r{rrtype} ~~ [qw(CNAME MX SOA PTR)];

   181         $r{data} =~ s{\Q$origin\E$}{\@} if $r{rrtype} ~~ [qw(CNAME MX)];

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

   183         $r{label} = do {

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

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

   186         };

   187 

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

   189           $len1 => $r{label},

   190           $r{ttl},

   191           $len2 => $r{rrtype},

   192           $r{data};

   193     };

   194     push @out, '; IF YOU EDIT the SOA record, INCREASE the serial number too!';

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

   196     return join "\n", @out, '';

   197 }

   198 

   199 sub delta {

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

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

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

   203     my @keys1 = keys %zone1;

   204     my @keys2 = keys %zone2;

   205     delete @zone1{@keys2};

   206     delete @zone2{@keys1};

   207 

   208     my (@add, @del);

   209     push @add, "@{$_}{qw/label ttl rrtype data/}" foreach values %zone2;

   210     push @del, "@{$_}{qw/label ttl rrtype data/}" foreach values %zone1;

   211 

   212     return () if (!@add and !@del);

   213     return (add => \@add, del => \@del);

   214 }

   215 

   216 sub edit {

   217     my %arg = %{ pop @_ } if ref $_[-1] eq ref {};

   218     my @zone = @_;

   219 

   220     # first make a backup copy

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

   222     $tmp->print(nice @zone);

   223     $tmp->say('; vim:tw=0:');

   224     $tmp->flush();

   225 

   226     system $arg{-editor} => $tmp->filename;

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

   228     ${ $arg{-backup} } = $tmp if $arg{-backup};

   229     return parse(do { local $/ = undef; <$tmp> }, { -skip => $arg{-skip} });

   230 }

   231 

   232 sub show {

   233     my ($add, $del) = @_;

   234     my @out = ((map { " - $_ " } @$del), (map { " + $_ " } @$add));

   235     return @out;

   236 }

   237 

   238 sub update {

   239     my %arg = %{ pop @_ } if ref $_[-1] eq ref {};

   240     my ($zone1, $add, $del) = @_;

   241 

   242     my $orig_soa =

   243       (grep { $_->{rrtype} eq 'SOA' } map { $_->{rrset} } @$zone1)[0];

   244 

   245     my @cmds = (

   246         $arg{-local} ? () : "server $arg{-server}",

   247         "prereq yxrrset @{$orig_soa}{qw{label rrtype data}}",

   248         (map { "update delete $_" } @$del),

   249         (map { "update add $_" } @$add),

   250         'send',

   251         'answer',

   252     );

   253     if ($arg{-dry}) {

   254         return say join "\n", '', @cmds, '' if $arg{-dry};

   255     }

   256     my @nsupdate = (

   257         'nsupdate',

   258         defined $arg{-debug} ? ('-d') : (),

   259         defined $arg{-key} ? (-k => $arg{-key}) : (),

   260         defined $arg{-local} ? ('-l') : (),

   261     );

   262 

   263     open(my $nsupdate, '|-') or do {

   264         exec @nsupdate;

   265         die "Can't exec @nsupdate: $!\n";

   266     };

   267     say $nsupdate join "\n", @cmds;

   268     close($nsupdate);

   269     say "nsupdate returned $?";

   270     return $? ? undef : 1;

   271 }

   272 

   273 sub save {

   274     my ($zone, $file) = @_;

   275     open(my $fh, '>', $file) or die "Can't open >$file: $!\n";

   276     print $fh nice @$zone;

   277     close($fh);

   278 

   279 }

   280 

   281 sub get_key {

   282     ReadMode 'cbreak';

   283     local $/ = \1;

   284     my $x = <STDIN>;

   285     ReadMode 'restore';

   286     print "\n";

   287     return $x;

   288 }

   289 

   290 sub get_auth_info {

   291     my $name = shift;

   292     my $server = shift;

   293     my %auth = (zone => undef, master => undef);

   294     state $resolver = Net::DNS::Resolver->new(

   295         defined $server ? (nameservers => [$server]) : ()

   296     );

   297     my $response = $resolver->send($name, 'SOA')

   298       or die $resolver->errorstring, "\n";

   299 

   300     #    use Data::Dumper;

   301     #    die Dumper $response;

   302 

   303     if (my @soa = grep { $_->type eq 'SOA' } $response->answer,

   304         $response->authority)

   305     {

   306         die "got multiple soa records\n" if @soa > 1;

   307         my $soa = $soa[0];

   308         return (

   309             name  => $soa->name,

   310             mname => $soa->mname,

   311         );

   312     }

   313 

   314     return $response->authority;

   315 }

   316 

   317 1;