| [808] | 1 | #!/usr/bin/perl
 | 
|---|
 | 2 | # Import a BIND zone file
 | 
|---|
| [818] | 3 | # Note we are not using Net:DNS::ZoneFile, because we want to convert $GENERATE
 | 
|---|
 | 4 | # directives straight into PTR template or A+PTR template metarecords
 | 
|---|
| [808] | 5 | ##
 | 
|---|
 | 6 | # Copyright 2020 Kris Deugau <kdeugau@deepnet.cx>
 | 
|---|
 | 7 | # 
 | 
|---|
 | 8 | #    This program is free software: you can redistribute it and/or modify
 | 
|---|
 | 9 | #    it under the terms of the GNU General Public License as published by
 | 
|---|
 | 10 | #    the Free Software Foundation, either version 3 of the License, or
 | 
|---|
 | 11 | #    (at your option) any later version. 
 | 
|---|
 | 12 | # 
 | 
|---|
 | 13 | #    This program is distributed in the hope that it will be useful,
 | 
|---|
 | 14 | #    but WITHOUT ANY WARRANTY; without even the implied warranty of
 | 
|---|
 | 15 | #    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 | 
|---|
 | 16 | #    GNU General Public License for more details.
 | 
|---|
 | 17 | # 
 | 
|---|
 | 18 | #    You should have received a copy of the GNU General Public License
 | 
|---|
 | 19 | #    along with this program.  If not, see <http://www.gnu.org/licenses/>.
 | 
|---|
 | 20 | ##
 | 
|---|
 | 21 | 
 | 
|---|
 | 22 | use strict;
 | 
|---|
 | 23 | use warnings;
 | 
|---|
| [819] | 24 | use Getopt::Long;
 | 
|---|
 | 25 | 
 | 
|---|
| [808] | 26 | use Data::Dumper;
 | 
|---|
 | 27 | 
 | 
|---|
| [819] | 28 | ##fixme
 | 
|---|
| [808] | 29 | use lib '.';
 | 
|---|
 | 30 | use DNSDB;
 | 
|---|
 | 31 | 
 | 
|---|
 | 32 | my $dnsdb = new DNSDB;
 | 
|---|
| [819] | 33 | my $doimport = 1;
 | 
|---|
| [808] | 34 | 
 | 
|---|
 | 35 | #print Dumper(\%reverse_typemap);
 | 
|---|
 | 36 | 
 | 
|---|
| [817] | 37 | local $dnsdb->{dbh}->{AutoCommit} = 0;
 | 
|---|
 | 38 | local $dnsdb->{dbh}->{RaiseError} = 1;
 | 
|---|
 | 39 | 
 | 
|---|
| [819] | 40 | # from tiny-import:  arguably can't use -r, -c is irrelevant.  others useful?
 | 
|---|
 | 41 |   # -r  rewrite imported files to comment imported records
 | 
|---|
 | 42 |   # -c  coerce/downconvert A+PTR = records to PTR
 | 
|---|
 | 43 |   # -l  swallow A+PTR as-is
 | 
|---|
 | 44 |   # -m  merge PTR and A/AAAA as possible
 | 
|---|
 | 45 |   # -t  trial mode;  don't commit to DB or actually rewrite flatfile (disables -r)
 | 
|---|
 | 46 |   # -g  import to specified group (name or ID) instead of group 1
 | 
|---|
 | 47 | 
 | 
|---|
| [817] | 48 | ##fixme:  command arguments/flags to set these to alternate values
 | 
|---|
 | 49 | my $group = 1;
 | 
|---|
 | 50 | my $status = 1;
 | 
|---|
 | 51 | my $location = '';
 | 
|---|
 | 52 | # we'll update this with the actual serial number from the SOA record later
 | 
|---|
 | 53 | my $serial = time();
 | 
|---|
 | 54 | 
 | 
|---|
| [819] | 55 | my @skipdefs;
 | 
|---|
 | 56 | my $skipfile;
 | 
|---|
 | 57 | 
 | 
|---|
 | 58 | GetOptions(
 | 
|---|
 | 59 |         "skip=s" => \@skipdefs,
 | 
|---|
 | 60 |         "skipfile=s" => \$skipfile,
 | 
|---|
 | 61 |         "test|dry-run" => sub { $doimport = 0; },
 | 
|---|
 | 62 | );
 | 
|---|
 | 63 | 
 | 
|---|
 | 64 | my $usage = "usage: bind-import [--skip pattern [--skip pattern2 ...]] [--skipfile file]
 | 
|---|
 | 65 |     zonename [zonefile]
 | 
|---|
 | 66 |         --skip    
 | 
|---|
 | 67 |                 Specify a string to skip in the records.  If an IP-like string is
 | 
|---|
 | 68 |                 used, and the zone is a reverse zone, it will also search for the
 | 
|---|
 | 69 |                 octet-reversed form.  Specify multiple times to skip multiple
 | 
|---|
 | 70 |                 different record patterns.
 | 
|---|
 | 71 |         --skipfile
 | 
|---|
 | 72 |                 A file containing patterns to skip.  Patterns from the file and
 | 
|---|
 | 73 |                 any --skip arguments are merged.
 | 
|---|
 | 74 |         zonename
 | 
|---|
 | 75 |                 The name of the zone to import.  Required.
 | 
|---|
 | 76 |         zonefile
 | 
|---|
 | 77 |                 Specify the zone file as an argument.  If not specified, the zone
 | 
|---|
 | 78 |                 data will be read from STDIN.
 | 
|---|
 | 79 | ";
 | 
|---|
 | 80 | 
 | 
|---|
| [808] | 81 | my $zname = shift @ARGV;
 | 
|---|
| [817] | 82 | my $origzone = $zname;
 | 
|---|
| [819] | 83 | die $usage if !$zname;
 | 
|---|
 | 84 | 
 | 
|---|
 | 85 | my $zonefile = shift @ARGV;
 | 
|---|
 | 86 | if(!$zonefile) {
 | 
|---|
 | 87 |   $zonefile = '&STDIN';
 | 
|---|
 | 88 | }
 | 
|---|
 | 89 | 
 | 
|---|
| [808] | 90 | my $rev = 'n';
 | 
|---|
 | 91 | my $zid;
 | 
|---|
| [819] | 92 | my %foundtypes;
 | 
|---|
| [808] | 93 | 
 | 
|---|
| [819] | 94 | if ($skipfile) {
 | 
|---|
 | 95 |   if (-f $skipfile) {
 | 
|---|
 | 96 |     open SKIP, "<$skipfile";
 | 
|---|
 | 97 |     while (<SKIP>) {
 | 
|---|
 | 98 |       push @skipdefs, $_;
 | 
|---|
 | 99 |     }
 | 
|---|
 | 100 |   } else {
 | 
|---|
 | 101 |     warn "skipfile $skipfile requested but it doesn't seem to exist.  Continuing.\n";
 | 
|---|
 | 102 |   }
 | 
|---|
 | 103 | }
 | 
|---|
 | 104 | 
 | 
|---|
 | 105 | #sub setreplace {
 | 
|---|
 | 106 | ##  print "dbg1: $_[0]\ndbg2: $_[1]\n";
 | 
|---|
 | 107 | ##($_[1] eq '' ? $replace = 1 : $replace = $_[1]);
 | 
|---|
 | 108 | #  if ($_[1] eq '') {
 | 
|---|
 | 109 | #    print "no arg value, setting 1\n";
 | 
|---|
 | 110 | #    $replace = 1;
 | 
|---|
 | 111 | #  } else {
 | 
|---|
 | 112 | #    print "arg value $_[1]\n";
 | 
|---|
 | 113 | #    $replace = $_[1];
 | 
|---|
 | 114 | #  }
 | 
|---|
 | 115 | #}
 | 
|---|
 | 116 | 
 | 
|---|
 | 117 | 
 | 
|---|
| [810] | 118 | my %amap;
 | 
|---|
 | 119 | my %namemap;
 | 
|---|
| [811] | 120 | my %cmap;
 | 
|---|
| [810] | 121 | 
 | 
|---|
| [819] | 122 | # wrap all the DB stuff in eval{}, so the entire thing either succeeds or fails.
 | 
|---|
 | 123 | 
 | 
|---|
 | 124 | eval {
 | 
|---|
 | 125 | 
 | 
|---|
 | 126 |   local $dnsdb->{dbh}->{AutoCommit} = 0;
 | 
|---|
 | 127 |   local $dnsdb->{dbh}->{RaiseError} = 1;
 | 
|---|
 | 128 | 
 | 
|---|
| [815] | 129 | ##fixme:  this is wrong, BIND zone files are generally complete and we're adding.  merging records is an entire fridge full of worms.
 | 
|---|
| [816] | 130 | ##fixme:  for import, should arguably check for zone *non*existence
 | 
|---|
| [819] | 131 |   if ($zname =~ /\.arpa\.?$/ || $zname =~ m,^[\d./]+$,) {
 | 
|---|
 | 132 |     $rev = 'y';
 | 
|---|
 | 133 |     $zname = _zone2cidr($zname) if $zname =~ /\.arpa\.?$/;
 | 
|---|
 | 134 |     $zid = $dnsdb->revID($zname,':ANY:');
 | 
|---|
 | 135 |     if ($zid) {
 | 
|---|
 | 136 |       die "zone $origzone already present, not merging records\n";
 | 
|---|
 | 137 |       $zname = new NetAddr::IP $zname;
 | 
|---|
 | 138 |       $zname = DNSDB::_ZONE($zname, 'ZONE', 'r', '.').($zname->{isv6} ? '.ip6.arpa' : '.in-addr.arpa');
 | 
|---|
 | 139 |     }
 | 
|---|
 | 140 |     $zid = $dnsdb->{dbh}->do("INSERT INTO revzones (revnet,group_id,status,default_location,zserial) VALUES (?,?,?,?,?) RETURNING rnds_id",
 | 
|---|
 | 141 |         undef, ($zname, $group, $status, $location, $serial));
 | 
|---|
| [817] | 142 | 
 | 
|---|
| [819] | 143 |   } else {
 | 
|---|
 | 144 | print "dbg: forward zone\n";
 | 
|---|
 | 145 |     $zid = $dnsdb->domainID($zname,':ANY:');
 | 
|---|
 | 146 |     if ($zid) {
 | 
|---|
 | 147 | #      die "zone $origzone already present, not merging records\n";
 | 
|---|
 | 148 | print "dbg: skip add domain\n";
 | 
|---|
 | 149 |     }
 | 
|---|
 | 150 | else {
 | 
|---|
 | 151 |     $zid = $dnsdb->{dbh}->do("INSERT INTO domains (domain,group_id,status,default_location,zserial) VALUES (?,?,?,?,?) RETURNING domain_id",
 | 
|---|
 | 152 |         undef, ($zname, $group, $status, $location, $serial));
 | 
|---|
| [808] | 153 | }
 | 
|---|
 | 154 | 
 | 
|---|
| [819] | 155 |   }
 | 
|---|
| [808] | 156 | 
 | 
|---|
| [819] | 157 |   die "error creating zone stub for $zname: ".$dnsdb->{dbh}->errstr if !$zid;
 | 
|---|
| [817] | 158 | 
 | 
|---|
 | 159 | 
 | 
|---|
| [819] | 160 | ##fixme: should probably make this a named argument so it doesn't get confused with the zone filename
 | 
|---|
 | 161 |   # still no sane way to expose a human-friendly view tag on the command line.
 | 
|---|
 | 162 |   my $view = shift @ARGV;
 | 
|---|
 | 163 |   $view = '' if !$view;
 | 
|---|
| [810] | 164 | 
 | 
|---|
| [819] | 165 |   ##fixme:  retrieve defttl from SOA record
 | 
|---|
 | 166 |   my $zonettl = 900;
 | 
|---|
 | 167 |   my $defttl = $zonettl;
 | 
|---|
 | 168 |   my $origin = "$zname.";       # to append to unqualified names
 | 
|---|
| [808] | 169 | 
 | 
|---|
| [819] | 170 |   # need to spin up a full state machine-ish thing, because BIND zone files are all about context
 | 
|---|
 | 171 |   # see ch4, p56-72 in the grasshopper book
 | 
|---|
 | 172 |   my $prevlabel = '';
 | 
|---|
 | 173 |   my $curlabel = '';
 | 
|---|
| [812] | 174 | 
 | 
|---|
| [819] | 175 |   my $i = 0;
 | 
|---|
| [813] | 176 | 
 | 
|---|
| [819] | 177 |   open ZONEDATA, "<$zonefile";
 | 
|---|
 | 178 | 
 | 
|---|
 | 179 |   while (my $rec = <ZONEDATA>) {
 | 
|---|
 | 180 |     chomp $rec;
 | 
|---|
 | 181 |     next if $rec =~ /^\s*$/;
 | 
|---|
 | 182 |     next if $rec =~ /^\s*;/;    # comments
 | 
|---|
 | 183 |     next if $rec =~ /^\s*\)/;   # SOA closing (possibly other records too?)
 | 
|---|
| [817] | 184 |                                 # arguably should do some more targeted voodoo when parsing the SOA details
 | 
|---|
| [813] | 185 | 
 | 
|---|
| [818] | 186 | ##fixme:  use external skiplist
 | 
|---|
| [817] | 187 |   # skip stale records that have no value
 | 
|---|
 | 188 |   next if /^ip-192-168-1(12|20)-\d+/;
 | 
|---|
 | 189 |   next if /ip.add.re.\d+\s*$/;
 | 
|---|
 | 190 | 
 | 
|---|
| [819] | 191 |   $i++;
 | 
|---|
 | 192 | last if $i > 7;
 | 
|---|
| [818] | 193 | #print "line $i: ($rec)\n";
 | 
|---|
| [819] | 194 |     if (my ($macro,$mdetail) = ($rec =~ /^\s*\$(TTL|ORIGIN|INCLUDE|GENERATE)\s+(.+)/) ) {
 | 
|---|
 | 195 |       # macro sort of thing;  $TTL and $ORIGIN most common.  $INCLUDE is a thing, expect it to be rare in live use tho
 | 
|---|
 | 196 |       if ($macro eq 'TTL') {
 | 
|---|
 | 197 |         $mdetail =~ s/\s*;.+$//;
 | 
|---|
 | 198 |         if ($mdetail =~ /^\d+$/) {
 | 
|---|
 | 199 |           $defttl = $mdetail;
 | 
|---|
 | 200 |         } else {
 | 
|---|
 | 201 |           warn "invalid \$TTL: $rec\n";
 | 
|---|
 | 202 |         }
 | 
|---|
 | 203 |       } elsif ($macro eq 'ORIGIN') {
 | 
|---|
| [810] | 204 | ##fixme:  going to skip the stupid case of "$ORIGIN com." and the like that lie
 | 
|---|
 | 205 | # between . and the root domain we were told we're importing;  anyone using such
 | 
|---|
 | 206 | # a mess outside the root servers is clearly insane
 | 
|---|
| [815] | 207 | 
 | 
|---|
 | 208 | # $ORIGIN supports cascading/nesting, by watching for fully-qualified names vs partial names.
 | 
|---|
 | 209 | 
 | 
|---|
 | 210 | print "origin ($mdetail)\n";
 | 
|---|
| [819] | 211 |         if ($mdetail =~ /\.$/) {
 | 
|---|
 | 212 |           $origin = $mdetail;
 | 
|---|
 | 213 |         } else {
 | 
|---|
 | 214 |           # append current origin to unqualified origin
 | 
|---|
 | 215 |           $origin = "$mdetail.$origin";
 | 
|---|
 | 216 |         }
 | 
|---|
| [815] | 217 | 
 | 
|---|
 | 218 | #      if ($mdetail eq '.' || $mdetail =~ /$zname\.$/ || $zname =~ /$mdetail\.$/) {
 | 
|---|
 | 219 | #        $origin = $mdetail;
 | 
|---|
 | 220 | #      } else {
 | 
|---|
 | 221 | #        # if we continue, we either use an $ORIGIN that's out of zone, or ignore it and potentially publish incorrect records.
 | 
|---|
 | 222 | #        die "bad \$ORIGIN: $_\n";
 | 
|---|
 | 223 | #      }
 | 
|---|
 | 224 | 
 | 
|---|
| [819] | 225 |       }
 | 
|---|
 | 226 |       elsif ($macro eq 'GENERATE') {
 | 
|---|
| [818] | 227 | # needs to generate CIDR range(s) as needed to match the start/stop points
 | 
|---|
| [819] | 228 |       }
 | 
|---|
 | 229 |     # not handling $INCLUDE or $GENERATE (altho the latter seems to be mostly a less-flexible version of the template types)
 | 
|---|
 | 230 |       next;
 | 
|---|
| [818] | 231 |     }
 | 
|---|
| [815] | 232 | 
 | 
|---|
| [819] | 233 |     my $origrec = $rec;
 | 
|---|
| [815] | 234 | 
 | 
|---|
 | 235 |   # leading whitespace indicates "same label as last record"
 | 
|---|
| [819] | 236 |     if ($rec =~ /^\s/) {
 | 
|---|
 | 237 |       $curlabel = $prevlabel;
 | 
|---|
| [817] | 238 | print "  found empty label, using previous label\n";
 | 
|---|
| [819] | 239 |     } else {
 | 
|---|
 | 240 |       ($curlabel) = ($rec =~ /^([\w\@_.-]+)\s/);
 | 
|---|
 | 241 |     }
 | 
|---|
| [815] | 242 | 
 | 
|---|
| [817] | 243 | print "  found '$curlabel'\n";
 | 
|---|
 | 244 | 
 | 
|---|
| [819] | 245 |     # magic name!
 | 
|---|
 | 246 |     $curlabel = "$zname." if $curlabel eq '@';
 | 
|---|
| [815] | 247 | 
 | 
|---|
| [819] | 248 |     # append $ORIGIN if name is not fully qualified.
 | 
|---|
 | 249 |     if ($curlabel !~ /\.$/) {
 | 
|---|
 | 250 |       $curlabel .= ($origin eq '.' ? '.' : ".$origin");
 | 
|---|
 | 251 |     }
 | 
|---|
| [817] | 252 | print "  expanded '$curlabel'\n";
 | 
|---|
| [815] | 253 | 
 | 
|---|
| [818] | 254 | # hack pthbptt
 | 
|---|
 | 255 | #$curlabel =~ s/\.\.$/./;
 | 
|---|
| [819] | 256 |     # check for zone scope.  skip bad records.
 | 
|---|
 | 257 |     if ($curlabel !~ /$zname.$/) {
 | 
|---|
 | 258 |       warn "bad record $origrec, maybe bad \$ORIGIN?\n";
 | 
|---|
 | 259 | # bweh?  maybe this should die()?
 | 
|---|
| [817] | 260 | last;
 | 
|---|
| [819] | 261 |       next;
 | 
|---|
 | 262 |     }
 | 
|---|
| [815] | 263 | 
 | 
|---|
| [819] | 264 |     # trim the label, if any
 | 
|---|
 | 265 |     $rec =~ s/^([\w\@_.-]*)\s+//;
 | 
|---|
| [817] | 266 | 
 | 
|---|
| [815] | 267 | #  # records must begin in the first column, no leading whitespace
 | 
|---|
 | 268 | #  my ($name) = /^([\w\@_.-]+)\s/;
 | 
|---|
 | 269 | 
 | 
|---|
| [813] | 270 | # foo IN A 1.2.3.4
 | 
|---|
 | 271 | #   IN A 2.3.4.5
 | 
|---|
 | 272 | # =
 | 
|---|
 | 273 | # foo.zone. IN A 1.2.3.4
 | 
|---|
 | 274 | # foo.zone. IN A 2.3.4.5
 | 
|---|
 | 275 | 
 | 
|---|
| [815] | 276 | #  # "empty" label records inherit the previous label
 | 
|---|
 | 277 | #  # RRs start in the first column by definition, so leading whitespace indicates an inherited label
 | 
|---|
 | 278 | #  if (/^\s+/) {
 | 
|---|
 | 279 | #    # fatal error.  if there is no previous label, we can by definition not set
 | 
|---|
 | 280 | #    # the current label based on it.  this can only happen on the very first
 | 
|---|
 | 281 | #    # record, following records will *ALWAYS* have a previous label
 | 
|---|
 | 282 | #    die "bad first record ($_):  no previous label\n" if !$prevlabel;
 | 
|---|
 | 283 | #    $name = $prevlabel;
 | 
|---|
 | 284 | #  }
 | 
|---|
| [813] | 285 | 
 | 
|---|
| [818] | 286 | #print "$i ($rec)\n";#\t$curlabel";
 | 
|---|
| [814] | 287 | 
 | 
|---|
| [813] | 288 | 
 | 
|---|
| [814] | 289 | 
 | 
|---|
 | 290 | 
 | 
|---|
| [815] | 291 | #  # append zone name to record name if missing AND not dot-terminated;
 | 
|---|
 | 292 | #  # this happens automagically for forward zones, but not reverse because Reasons.  (fixme?)
 | 
|---|
 | 293 | #  # suck up and deal with the error if the dot-termiated name is out of zone;  should be
 | 
|---|
 | 294 | #  # impossible with valid BIND zone file but...
 | 
|---|
 | 295 | #  if ($name !~ /\.$/) {
 | 
|---|
 | 296 | #    $name .= ".$zname" if $name !~ /$zname$/;
 | 
|---|
 | 297 | #  } else {
 | 
|---|
 | 298 | #    warn "skipping out-of-zone record:\n\t($_)\n" if $name !~ /$zname\.$/;
 | 
|---|
 | 299 | #    next;
 | 
|---|
 | 300 | #  }
 | 
|---|
| [813] | 301 | 
 | 
|---|
 | 302 | 
 | 
|---|
| [819] | 303 |     my $nc = 0;
 | 
|---|
 | 304 |     my $class = 'IN';
 | 
|---|
 | 305 |     my $type;
 | 
|---|
 | 306 |     my $ttl;
 | 
|---|
 | 307 |     my $distance;
 | 
|---|
 | 308 |     my $weight;
 | 
|---|
 | 309 |     my $port;
 | 
|---|
 | 310 |     my $badrec;
 | 
|---|
 | 311 |     my $curatom = 'class';
 | 
|---|
| [813] | 312 | 
 | 
|---|
| [819] | 313 |     # unpack the class, TTL, and type
 | 
|---|
 | 314 |     eval {
 | 
|---|
 | 315 |       for (; $nc < 3; $nc++) {
 | 
|---|
 | 316 |         my ($atom) = ($rec =~ /^([\w\d.]+)\s/);
 | 
|---|
 | 317 |         # should be safe?
 | 
|---|
 | 318 |         last if !$atom;
 | 
|---|
 | 319 |         last if $type;
 | 
|---|
| [817] | 320 | #print "nc:$nc: $atom\n";
 | 
|---|
| [819] | 321 |         if ($atom =~ /^\d+$/) {
 | 
|---|
 | 322 |           if (defined($ttl)) {
 | 
|---|
| [817] | 323 |             die "bad record ($origrec)\n";
 | 
|---|
 | 324 | #            warn "bad record ($origrec)\n";
 | 
|---|
 | 325 | #            $badrec = 1;
 | 
|---|
 | 326 | #            last;
 | 
|---|
| [819] | 327 |           } else {
 | 
|---|
 | 328 |             if ($curatom ne 'class' && $curatom ne 'ttl') {
 | 
|---|
 | 329 |               die "bad record ($origrec)\n";
 | 
|---|
 | 330 | #              warn "bad record ($origrec)\n";
 | 
|---|
 | 331 | #              $badrec = 1;
 | 
|---|
 | 332 | #              last;
 | 
|---|
 | 333 |             }
 | 
|---|
 | 334 |             $curatom = 'ttl';
 | 
|---|
 | 335 |             $ttl = $atom;
 | 
|---|
| [817] | 336 |           }
 | 
|---|
| [816] | 337 |         }
 | 
|---|
| [817] | 338 | 
 | 
|---|
| [819] | 339 |         elsif ($atom =~ /^IN|CS|CH|HS$/) {
 | 
|---|
| [817] | 340 | #print "a$nc: d2: atom [$atom]\n        $rec\n" if $i == $debugid;
 | 
|---|
| [819] | 341 |           if ($atom =~ /CS|CH|HS/) {
 | 
|---|
 | 342 |             die "unsupported class $atom in record ($origrec)\n";
 | 
|---|
 | 343 | #            warn "unsupported class $atom in record ($origrec)\n";
 | 
|---|
 | 344 | #            $badrec = 1;
 | 
|---|
 | 345 | #            last;
 | 
|---|
 | 346 |           }
 | 
|---|
 | 347 |           $curatom = 'class';
 | 
|---|
 | 348 |           $class = $atom;
 | 
|---|
| [817] | 349 |         }
 | 
|---|
 | 350 | 
 | 
|---|
| [819] | 351 |         elsif ($atom =~ /^[A-Z]+/) {
 | 
|---|
| [817] | 352 | #      print "dbg: type $atom\n";
 | 
|---|
| [819] | 353 |           if ($reverse_typemap{$atom}) {
 | 
|---|
 | 354 |             $type = $atom;
 | 
|---|
 | 355 |           } else {
 | 
|---|
 | 356 |             die "unknown type $atom in record ($origrec)\n";
 | 
|---|
 | 357 |           }
 | 
|---|
| [817] | 358 |         }
 | 
|---|
| [819] | 359 |         $rec =~ s/^$atom\s*//;
 | 
|---|
| [817] | 360 |       }
 | 
|---|
| [819] | 361 |     }; # record class/type/TTL parse
 | 
|---|
 | 362 |     if ($@) {
 | 
|---|
 | 363 |       warn $@;
 | 
|---|
 | 364 |       next;
 | 
|---|
| [815] | 365 |     }
 | 
|---|
 | 366 | 
 | 
|---|
| [818] | 367 | ##todo:  BIND conflates a repeated label with repeating the TTL too.  Matter of opinion whether that's really correct or not.
 | 
|---|
| [819] | 368 |     # set default TTL here so we can detect a TTL in the loop above
 | 
|---|
 | 369 |     $ttl = $defttl if !defined($ttl);
 | 
|---|
| [817] | 370 | 
 | 
|---|
| [816] | 371 | #next if $badrec;
 | 
|---|
| [815] | 372 | 
 | 
|---|
| [819] | 373 |     $prevlabel = $curlabel;
 | 
|---|
| [815] | 374 | 
 | 
|---|
| [814] | 375 | 
 | 
|---|
| [817] | 376 | ## by convention the optional TTL leads the optional class, but they're apparently swappable.
 | 
|---|
 | 377 | #  my ($ttl) = /^(\d+)?\s/;
 | 
|---|
 | 378 | #  if (defined $ttl) {
 | 
|---|
 | 379 | #    # TTL may be zero
 | 
|---|
 | 380 | #    s/(\d+)?\s+//;
 | 
|---|
 | 381 | #  } else {
 | 
|---|
 | 382 | #    # Fall back to zone default TTL
 | 
|---|
 | 383 | #    $ttl = $zonettl;
 | 
|---|
 | 384 | #  }
 | 
|---|
 | 385 | #  my ($class) = /^(IN|CS|CH|HS|\d+)\s/;
 | 
|---|
 | 386 | #  if (defined $class) {
 | 
|---|
 | 387 | #    if ($class =~ /\d+/) {
 | 
|---|
 | 388 | #      
 | 
|---|
 | 389 | #    }
 | 
|---|
 | 390 | #    if ($class ne 'IN') {
 | 
|---|
 | 391 | #      warn "Non-Internet class ($class) records not supported:\n\t$origrec\n";
 | 
|---|
 | 392 | #      next;
 | 
|---|
 | 393 | #    }
 | 
|---|
 | 394 | #    s/(IN|CS|CH|HS)\s+//;
 | 
|---|
 | 395 | #  } else {
 | 
|---|
 | 396 | #    $class = 'IN';
 | 
|---|
 | 397 | #  }
 | 
|---|
 | 398 | #  my ($type) = /([A-Z-]+)\s/;
 | 
|---|
 | 399 | #  if (!$reverse_typemap{$type}) {
 | 
|---|
 | 400 | #    warn "Unknown type $type, skipping\n\t($rec)\n";
 | 
|---|
 | 401 | #    next;
 | 
|---|
 | 402 | #  }
 | 
|---|
 | 403 | #  s/([A-Z-]+)\s+//;
 | 
|---|
 | 404 | #  chomp;
 | 
|---|
 | 405 | 
 | 
|---|
 | 406 | 
 | 
|---|
| [819] | 407 |     my $itype = $reverse_typemap{$type};
 | 
|---|
 | 408 |     my $rdata = $rec;
 | 
|---|
| [808] | 409 | 
 | 
|---|
| [812] | 410 |   # SOA is the only type that may span multiple lines.  Probably.  Note even AXFRed zones write multiline SOA records:
 | 
|---|
 | 411 |   #@       IN      SOA     test.example.invalid.   test.example.invalid.   (2020082500 7200 900 604800 3600)
 | 
|---|
 | 412 |   #        IN      NS      olddns.example.com.
 | 
|---|
 | 413 |   #        IN      MX      1 fred.foo.bar.invalid.
 | 
|---|
 | 414 |   #foo     IN      A       192.168.16.45
 | 
|---|
 | 415 |   # AXFR'ed zone file gets written as
 | 
|---|
 | 416 |   #$ORIGIN .
 | 
|---|
 | 417 |   #$TTL 3600       ; 1 hour
 | 
|---|
 | 418 |   #example.invalid         IN SOA  test.example.invalid. test.example.invalid. (
 | 
|---|
 | 419 |   #                                2020082500 ; serial
 | 
|---|
 | 420 |   #                                7200       ; refresh (2 hours)
 | 
|---|
 | 421 |   #                                900        ; retry (15 minutes)
 | 
|---|
 | 422 |   #                                604800     ; expire (1 week)
 | 
|---|
 | 423 |   #                                3600       ; minimum (1 hour)
 | 
|---|
 | 424 |   #                                )
 | 
|---|
 | 425 |   #                        NS      olddns.example.com.
 | 
|---|
 | 426 |   #                        MX      1 fred.foo.bar.invalid.
 | 
|---|
 | 427 |   #$ORIGIN example.invalid.
 | 
|---|
 | 428 |   #foo                     A       192.168.16.45
 | 
|---|
| [819] | 429 |   $foundtypes{$type}++;
 | 
|---|
| [812] | 430 | 
 | 
|---|
| [818] | 431 | ##fixme:  strip trailing . here?  dnsadmin's normalized internal format omits it, some validation fails or may go funky
 | 
|---|
 | 432 | 
 | 
|---|
| [819] | 433 |     if ($type eq 'SOA') {
 | 
|---|
 | 434 |       my ($ns, $adminmail) = ($rdata =~ /([\w.]+)\s+([\w.]+)\s+\(/);
 | 
|---|
 | 435 |       die "Can't parse gibberish SOAish record: $rec\n" if !$ns;
 | 
|---|
 | 436 |       $rdata =~ s/([\w.]+)\s+([\w.]+)\s+\(\s*//;
 | 
|---|
| [812] | 437 | 
 | 
|---|
| [819] | 438 |       # There are probably more efficient ways to do this but the SOA record
 | 
|---|
 | 439 |       # format is essentially character based, not line-based.
 | 
|---|
 | 440 |       # In theory the SOA serial etc may be spread over up to 5 lines, in any combination.
 | 
|---|
| [812] | 441 | 
 | 
|---|
| [819] | 442 |       # Parse fields from $rdata if present
 | 
|---|
 | 443 |       my @soabits;
 | 
|---|
 | 444 |       my @soafirst = split /\s+/, $rdata;
 | 
|---|
 | 445 |       while (my $f = shift @soafirst) {
 | 
|---|
| [813] | 446 |         last if $f !~ /^\d/;
 | 
|---|
| [819] | 447 |         push @soabits, $f;
 | 
|---|
| [813] | 448 |       }
 | 
|---|
| [819] | 449 | 
 | 
|---|
 | 450 |       # Read more lines if we don't have enough SOA fields filled
 | 
|---|
 | 451 |       while (scalar(@soabits) < 5) {
 | 
|---|
 | 452 |         my $tmp = <ZONEDATA>;
 | 
|---|
 | 453 |         $tmp =~ s/^\s*//;
 | 
|---|
 | 454 |         my @tmpsoa = split /\s+/, $tmp;
 | 
|---|
 | 455 |         while (my $f = shift @tmpsoa) {
 | 
|---|
 | 456 |           last if $f !~ /^\d/;
 | 
|---|
 | 457 |           push @soabits, $f;  
 | 
|---|
 | 458 |         }
 | 
|---|
 | 459 |         if (scalar(@soabits) == 5) {
 | 
|---|
 | 460 |           last;
 | 
|---|
 | 461 |         }
 | 
|---|
| [813] | 462 |       }
 | 
|---|
| [819] | 463 |       my @soavals = ($zid, "$adminmail:$ns", 6, join(':', @soabits), $ttl, $location);
 | 
|---|
 | 464 | # host = $adminmail:$ns
 | 
|---|
 | 465 | # val = join(':', @soabits);
 | 
|---|
 | 466 | 
 | 
|---|
 | 467 |       if ($rev eq 'y') {
 | 
|---|
 | 468 |         $dnsdb->{dbh}->do("UPDATE revzones SET zserial = ? WHERE rdns_id = ?", undef, $soabits[0], $zid);
 | 
|---|
 | 469 |         $dnsdb->{dbh}->do("INSERT INTO records (rdns_id,host,type,val,ttl,location) VALUES (?,?,?,?,?,?)", undef, @soavals);
 | 
|---|
 | 470 |       } else {
 | 
|---|
 | 471 |         $dnsdb->{dbh}->do("UPDATE domains SET zserial = ? WHERE domain_id = ?", undef, $soabits[0], $zid);
 | 
|---|
 | 472 |         $dnsdb->{dbh}->do("INSERT INTO records (domain_id,host,type,val,ttl,location) VALUES (?,?,?,?,?,?)", undef, @soavals);
 | 
|---|
 | 473 |       }
 | 
|---|
| [818] | 474 | #  $dnsdb->{dbh}->do("INSERT INTO records () VALUES ()");
 | 
|---|
 | 475 | #  next;
 | 
|---|
 | 476 | #Zfqdn:mname:rname:ser:ref:ret:exp:min:ttl:timestamp:lo
 | 
|---|
 | 477 | #print "Z$zname:$ns:$adminmail:$soabits[0]:$soabits[1]:$soabits[2]:$soabits[3]:$soabits[4]:$ttl\n";
 | 
|---|
| [819] | 478 |     } # SOA
 | 
|---|
| [813] | 479 | 
 | 
|---|
| [818] | 480 | 
 | 
|---|
| [819] | 481 |     # we're using DNSDB::addrec(), so we'll skip detailed validation of other records.  Most won't need further breakdown
 | 
|---|
| [818] | 482 | 
 | 
|---|
| [819] | 483 |     elsif ($type eq 'A') {
 | 
|---|
| [818] | 484 | #print "+$curlabel:$rdata:$ttl\n";
 | 
|---|
| [819] | 485 |     }
 | 
|---|
| [818] | 486 | 
 | 
|---|
| [819] | 487 |     elsif ($type eq 'NS') {
 | 
|---|
| [818] | 488 | #print "\&$curlabel::$rdata:$ttl\n";
 | 
|---|
| [819] | 489 |     }
 | 
|---|
| [818] | 490 | 
 | 
|---|
| [819] | 491 |     elsif ($type eq 'CNAME') {
 | 
|---|
| [818] | 492 | #print "C$curlabel:$rdata:$ttl\n";
 | 
|---|
| [819] | 493 |     }
 | 
|---|
| [818] | 494 | 
 | 
|---|
| [819] | 495 |     elsif ($type eq 'PTR') {
 | 
|---|
 | 496 |     }
 | 
|---|
| [818] | 497 | 
 | 
|---|
| [819] | 498 |     elsif ($type eq 'MX') {
 | 
|---|
 | 499 |       ($distance) = ($rdata =~ /^(\d+)\s+/);
 | 
|---|
 | 500 |       if (!defined($distance)) {
 | 
|---|
 | 501 |         warn "malformed MX record: $origrec, skipping\n";
 | 
|---|
 | 502 |         next;
 | 
|---|
 | 503 |       }
 | 
|---|
 | 504 |       $rdata =~ s/^\d+\s+//;
 | 
|---|
| [818] | 505 |     }
 | 
|---|
 | 506 | 
 | 
|---|
| [819] | 507 |     elsif ($type eq 'TXT') {
 | 
|---|
 | 508 |       # Quotes may arguably be syntactically required, but they're not actually part of the record data
 | 
|---|
 | 509 |       $rdata =~ s/^"//;
 | 
|---|
 | 510 |       $rdata =~ s/"$//;
 | 
|---|
| [818] | 511 | #print "'$curlabel:$rdata:$ttl\n";
 | 
|---|
| [819] | 512 |     }
 | 
|---|
| [808] | 513 | 
 | 
|---|
| [819] | 514 |     elsif ($type eq 'RP') {
 | 
|---|
 | 515 |     }
 | 
|---|
| [810] | 516 | 
 | 
|---|
| [819] | 517 |     elsif ($type eq 'AAAA') {
 | 
|---|
 | 518 |     }
 | 
|---|
| [818] | 519 | 
 | 
|---|
| [819] | 520 |     elsif ($type eq 'SRV') {
 | 
|---|
 | 521 |       ($distance, $weight, $port) = ($rdata =~ /^(\d+)\s+(\d+)\s+(\d+)\s+/);
 | 
|---|
 | 522 |       if ( !defined($distance) || !defined($weight) || !defined($port) ) {
 | 
|---|
 | 523 |         warn "malformed SRV record: $origrec, skipping\n";
 | 
|---|
 | 524 |         next;
 | 
|---|
 | 525 |       }
 | 
|---|
 | 526 |       $rdata =~ s/^\d+\s+\d+\s+\d+\s+//;
 | 
|---|
| [818] | 527 |     }
 | 
|---|
 | 528 | 
 | 
|---|
| [819] | 529 |     # basically a dedicated clone of TXT, not sure anything actually looks up type SPF.
 | 
|---|
 | 530 |     # BIND autogenerates them from SPF TXT records.
 | 
|---|
 | 531 |     elsif ($type eq 'SPF') {
 | 
|---|
 | 532 |       # Quotes may arguably be syntactically required, but they're not actually part of the record data
 | 
|---|
 | 533 |       $rdata =~ s/^"//;
 | 
|---|
 | 534 |       $rdata =~ s/"$//;
 | 
|---|
 | 535 |     }
 | 
|---|
| [818] | 536 | 
 | 
|---|
 | 537 | #  elsif ($type eq 'TXT') {
 | 
|---|
 | 538 | #  elsif ($type eq 'TXT') {
 | 
|---|
 | 539 | 
 | 
|---|
| [819] | 540 |     else {
 | 
|---|
 | 541 |       warn "unsupported type $type, may not import correctly\n";
 | 
|---|
 | 542 |     }
 | 
|---|
| [818] | 543 | 
 | 
|---|
| [808] | 544 | no warnings qw(uninitialized);
 | 
|---|
| [818] | 545 | #print "parsed: '$curlabel' '$class' '$ttl' '$type'->'$itype' '$rdata'\n";
 | 
|---|
| [808] | 546 | #print;
 | 
|---|
 | 547 | #;imap   IN      900     CNAME   deepnet.cx.
 | 
|---|
 | 548 | ##fixme:  not sure how to handle the case where someone leaves off the class.
 | 
|---|
| [819] | 549 |     if ($doimport) {
 | 
|---|
 | 550 |       my ($code, $msg);
 | 
|---|
 | 551 |       if ($rev eq 'n') {
 | 
|---|
 | 552 |         ($code,$msg) = $dnsdb->addRec('n', $rev, $zid, \$curlabel, \$itype, \$rdata, $ttl,
 | 
|---|
 | 553 |           $location, undef, undef, $distance, $weight, $port);
 | 
|---|
 | 554 |       } else {
 | 
|---|
 | 555 |         ($code,$msg) = $dnsdb->addRec('y', $rev, $zid, \$rdata, \$itype, \$curlabel, $ttl,
 | 
|---|
 | 556 |           $location, undef, undef, $distance, $weight, $port);
 | 
|---|
 | 557 |       }
 | 
|---|
 | 558 |       print "$code: $msg\n";
 | 
|---|
| [810] | 559 |     }
 | 
|---|
| [819] | 560 | #  $i++;
 | 
|---|
| [809] | 561 |   }
 | 
|---|
| [819] | 562 | 
 | 
|---|
 | 563 | };
 | 
|---|
 | 564 | if ($@) {
 | 
|---|
 | 565 |   warn "Error parsing zonefile: $@\n";
 | 
|---|
 | 566 |   $dnsdb->{dbh}->rollback;
 | 
|---|
 | 567 |   exit;
 | 
|---|
| [808] | 568 | }
 | 
|---|
| [810] | 569 | 
 | 
|---|
 | 570 | #print Dumper \%amap;
 | 
|---|
| [811] | 571 | #print Dumper \%namemap;
 | 
|---|
 | 572 | #print Dumper \%cmap;
 | 
|---|
 | 573 | 
 | 
|---|
| [818] | 574 | #foreach my $n (keys %amap) {
 | 
|---|
 | 575 | #  foreach my $ip (@{$amap{$n}}) {
 | 
|---|
 | 576 | ##print "$ip    $n\n";
 | 
|---|
 | 577 | #    push @{$namemap{$ip}}, $n unless grep $n, @{$namemap{$ip}};
 | 
|---|
 | 578 | #  }
 | 
|---|
 | 579 | #}
 | 
|---|
| [810] | 580 | 
 | 
|---|
| [818] | 581 | #foreach my $c (keys %cmap) {
 | 
|---|
 | 582 | #  if ($amap{$c}) {
 | 
|---|
 | 583 | #    print Dumper(\@{$amap{$c}});
 | 
|---|
 | 584 | #  }
 | 
|---|
 | 585 | ##  print $amap{$c};
 | 
|---|
 | 586 | #}
 | 
|---|
| [811] | 587 | 
 | 
|---|
 | 588 | # cname targ -> IP
 | 
|---|
 | 589 | 
 | 
|---|
 | 590 | #foreach my $ip (sort keys %namemap) {
 | 
|---|
 | 591 | #  print "$ip   ".join(' ', @{$namemap{$ip}})."\n";
 | 
|---|
 | 592 | #}
 | 
|---|
 | 593 | 
 | 
|---|
| [819] | 594 | ##fixme: might not be sane, addRec() above does a commit() internally.
 | 
|---|
 | 595 | #$dnsdb->{dbh}->rollback;
 | 
|---|
 | 596 | $dnsdb->{dbh}->commit;
 | 
|---|
| [818] | 597 | 
 | 
|---|
 | 598 | foreach my $t (keys %foundtypes) {
 | 
|---|
 | 599 |   print "found $t: $foundtypes{$t}\n";
 | 
|---|
 | 600 | }
 | 
|---|