source: trunk/bind-import@ 817

Last change on this file since 817 was 817, checked in by Kris Deugau, 4 years ago

/trunk

Tenth sampled iteration of bind-import

File size: 12.6 KB
RevLine 
[808]1#!/usr/bin/perl
2# Import a BIND zone file
3##
4# Copyright 2020 Kris Deugau <kdeugau@deepnet.cx>
5#
6# This program is free software: you can redistribute it and/or modify
7# it under the terms of the GNU General Public License as published by
8# the Free Software Foundation, either version 3 of the License, or
9# (at your option) any later version.
10#
11# This program is distributed in the hope that it will be useful,
12# but WITHOUT ANY WARRANTY; without even the implied warranty of
13# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14# GNU General Public License for more details.
15#
16# You should have received a copy of the GNU General Public License
17# along with this program. If not, see <http://www.gnu.org/licenses/>.
18##
19
20use strict;
21use warnings;
22use Data::Dumper;
23
24use lib '.';
25use DNSDB;
26
27my $dnsdb = new DNSDB;
[810]28my $doimport = 0;
[808]29
30#print Dumper(\%reverse_typemap);
31
[817]32local $dnsdb->{dbh}->{AutoCommit} = 0;
33local $dnsdb->{dbh}->{RaiseError} = 1;
34
35##fixme: command arguments/flags to set these to alternate values
36my $group = 1;
37my $status = 1;
38my $location = '';
39# we'll update this with the actual serial number from the SOA record later
40my $serial = time();
41
[808]42my $zname = shift @ARGV;
[817]43my $origzone = $zname;
[813]44die "usage: bind-import zonename\n" if !$zname;
[808]45my $rev = 'n';
46my $zid;
47
[810]48my %amap;
49my %namemap;
[811]50my %cmap;
[810]51
[815]52##fixme: this is wrong, BIND zone files are generally complete and we're adding. merging records is an entire fridge full of worms.
[816]53##fixme: for import, should arguably check for zone *non*existence
[809]54if ($zname =~ /\.arpa\.?$/ || $zname =~ m,^[\d./]+$,) {
[808]55 $rev = 'y';
[809]56 $zname = _zone2cidr($zname) if $zname =~ /\.arpa\.?$/;
[808]57 $zid = $dnsdb->revID($zname,':ANY:');
[809]58 if ($zid) {
[817]59 die "zone $origzone already present, not merging records\n";
60#$zname = new NetAddr::IP $zname;
61# $zname = DNSDB::_ZONE($zname, 'ZONE', 'r', '.').($zname->{isv6} ? '.ip6.arpa' : '.in-addr.arpa');
[809]62 }
[817]63 $zid = $dnsdb->{dbh}->do("INSERT INTO revzones (revnet,group_id,status,default_location,zserial) VALUES (?,?,?,?,?) RETURNING rnds_id",
64 undef, ($zname, $group, $status, $location, $serial));
65
[808]66} else {
67 $zid = $dnsdb->domainID($zname,':ANY:');
[817]68 if ($zid) {
69 die "zone $origzone already present, not merging records\n";
70 }
71 $zid = $dnsdb->{dbh}->do("INSERT INTO domains (domain,group_id,status,default_location,zserial) VALUES (?,?,?,?,?) RETURNING domain_id",
72 undef, ($zname, $group, $status, $location, $serial));
[808]73}
74
[817]75die "error creating zone stub for $zname: ".$dnsdb->{dbh}->errstr if !$zid;
[808]76
[817]77
78
[810]79# still no sane way to expose a human-friendly view tag on the command line.
80my $view = shift @ARGV;
81$view = '' if !$view;
82
[808]83##fixme: retrieve defttl from SOA record
84my $zonettl = 900;
[810]85my $defttl = $zonettl;
[817]86my $origin = "$zname."; # to append to unqualified names
[808]87
[810]88# need to spin up a full state machine-ish thing, because BIND zone files are all about context
[812]89# see ch4, p56-72 in the grasshopper book
90my $prevlabel = '';
91my $curlabel = '';
92
[813]93my $i = 0;
94
[817]95while (my $rec = <>) {
96 chomp $rec;
97 next if $rec =~ /^\s*$/;
98 next if $rec =~ /^\s*;/; # comments
99 next if $rec =~ /^\s*\)/; # SOA closing (possibly other records too?)
100 # arguably should do some more targeted voodoo when parsing the SOA details
[813]101
[817]102 # skip stale records that have no value
103 next if /^ip-192-168-1(12|20)-\d+/;
104 next if /ip.add.re.\d+\s*$/;
105
106#last if ++$i > 4;
107print "($rec)\n";
108 if (my ($macro,$mdetail) = ($rec =~ /^\s*\$(TTL|ORIGIN|INCLUDE|GENERATE)\s+(.+)/) ) {
[810]109 # macro sort of thing; $TTL and $ORIGIN most common. $INCLUDE is a thing, expect it to be rare in live use tho
110 if ($macro eq 'TTL') {
[815]111 $mdetail =~ s/\s*;.+$//;
[810]112 if ($mdetail =~ /^\d+$/) {
113 $defttl = $mdetail;
114 } else {
[817]115 warn "invalid \$TTL: $rec\n";
[810]116 }
117 } elsif ($macro eq 'ORIGIN') {
118##fixme: going to skip the stupid case of "$ORIGIN com." and the like that lie
119# between . and the root domain we were told we're importing; anyone using such
120# a mess outside the root servers is clearly insane
[815]121
122# $ORIGIN supports cascading/nesting, by watching for fully-qualified names vs partial names.
123
124print "origin ($mdetail)\n";
125 if ($mdetail =~ /\.$/) {
126 $origin = $mdetail;
[810]127 } else {
[815]128 # append current origin to unqualified origin
129 $origin = "$mdetail.$origin";
[810]130 }
[815]131
132# if ($mdetail eq '.' || $mdetail =~ /$zname\.$/ || $zname =~ /$mdetail\.$/) {
133# $origin = $mdetail;
134# } else {
135# # if we continue, we either use an $ORIGIN that's out of zone, or ignore it and potentially publish incorrect records.
136# die "bad \$ORIGIN: $_\n";
137# }
138
[810]139 }
[812]140 # not handling $INCLUDE or $GENERATE (altho the latter seems to be mostly a less-flexible version of the template types)
[810]141 next;
142 }
[815]143
[817]144 my $origrec = $rec;
[815]145
146 # leading whitespace indicates "same label as last record"
[817]147 if ($rec =~ /^\s/) {
[815]148 $curlabel = $prevlabel;
[817]149print " found empty label, using previous label\n";
[815]150 } else {
[817]151 ($curlabel) = ($rec =~ /^([\w\@_.-]+)\s/);
[815]152 }
153
[817]154print " found '$curlabel'\n";
155
[815]156 # magic name!
157 $curlabel = "$zname." if $curlabel eq '@';
158
159 # append $ORIGIN if name is not fully qualified.
160 if ($curlabel !~ /\.$/) {
[817]161 $curlabel .= ".$origin";
[815]162 }
[817]163print " expanded '$curlabel'\n";
[815]164
165 # check for zone scope. skip bad records.
166 if ($curlabel !~ /$zname.$/) {
167 warn "bad record $origrec, maybe bad \$ORIGIN?\n";
[817]168last;
[815]169 next;
170 }
171
[817]172 # trim the label, if any
173 $rec =~ s/^([\w\@_.-]*)\s+//;
174
[815]175# # records must begin in the first column, no leading whitespace
176# my ($name) = /^([\w\@_.-]+)\s/;
177
[813]178# foo IN A 1.2.3.4
179# IN A 2.3.4.5
180# =
181# foo.zone. IN A 1.2.3.4
182# foo.zone. IN A 2.3.4.5
183
[815]184# # "empty" label records inherit the previous label
185# # RRs start in the first column by definition, so leading whitespace indicates an inherited label
186# if (/^\s+/) {
187# # fatal error. if there is no previous label, we can by definition not set
188# # the current label based on it. this can only happen on the very first
189# # record, following records will *ALWAYS* have a previous label
190# die "bad first record ($_): no previous label\n" if !$prevlabel;
191# $name = $prevlabel;
192# }
[813]193
[817]194print "$i ($rec)\n";#\t$curlabel";
[814]195
[813]196
[814]197
198
[815]199# # append zone name to record name if missing AND not dot-terminated;
200# # this happens automagically for forward zones, but not reverse because Reasons. (fixme?)
201# # suck up and deal with the error if the dot-termiated name is out of zone; should be
202# # impossible with valid BIND zone file but...
203# if ($name !~ /\.$/) {
204# $name .= ".$zname" if $name !~ /$zname$/;
205# } else {
206# warn "skipping out-of-zone record:\n\t($_)\n" if $name !~ /$zname\.$/;
207# next;
208# }
[813]209
210
[817]211 my $nc = 0;
212 my $class = 'IN';
213 my $ttl;
214 my $type;
215 my $badrec;
216 my $curatom = 'class';
[813]217
[817]218 eval {
219 for (; $nc < 3; $nc++) {
220 my ($atom) = ($rec =~ /^([\w\d.]+)\s/);
221 # should be safe?
222 last if !$atom;
223 last if $type;
224#print "nc:$nc: $atom\n";
225 if ($atom =~ /^\d+$/) {
226 if (defined($ttl)) {
[816]227 die "bad record ($origrec)\n";
228# warn "bad record ($origrec)\n";
229# $badrec = 1;
230# last;
[817]231 } else {
232 if ($curatom ne 'class' && $curatom ne 'ttl') {
233 die "bad record ($origrec)\n";
234# warn "bad record ($origrec)\n";
235# $badrec = 1;
236# last;
237 }
238 $curatom = 'ttl';
239 $ttl = $atom;
[816]240 }
[815]241 }
[817]242
243 elsif ($atom =~ /^IN|CS|CH|HS$/) {
244#print "a$nc: d2: atom [$atom]\n $rec\n" if $i == $debugid;
245 if ($atom =~ /CS|CH|HS/) {
246 die "unsupported class $atom in record ($origrec)\n";
247# warn "unsupported class $atom in record ($origrec)\n";
248# $badrec = 1;
249# last;
250 }
251 $curatom = 'class';
252 $class = $atom;
[816]253 }
[817]254
255 elsif ($atom =~ /^[A-Z]+/) {
256# print "dbg: type $atom\n";
257 if ($reverse_typemap{$atom}) {
258 $type = $atom;
259 } else {
260 die "unknown type $atom in record ($origrec)\n";
261 }
262 }
263 $rec =~ s/^$atom\s*//;
[815]264 }
[817]265 };
266 if ($@) {
267 warn $@;
268 next;
[815]269 }
270
[817]271 # set default TTL here so we can detect a TTL in the loop above
272 $ttl = $defttl if !defined($ttl);
273
[816]274#next if $badrec;
[815]275
276
[814]277##fixme: drop curlabel? not sure it's needed
[815]278#$curlabel = $name;
[813]279$prevlabel = $curlabel;
[814]280##todo: BIND conflates a repeated label with repeating the TTL too. Matter of opinion whether that's really correct or not.
281
282
[815]283
[817]284## by convention the optional TTL leads the optional class, but they're apparently swappable.
285# my ($ttl) = /^(\d+)?\s/;
286# if (defined $ttl) {
287# # TTL may be zero
288# s/(\d+)?\s+//;
289# } else {
290# # Fall back to zone default TTL
291# $ttl = $zonettl;
292# }
293# my ($class) = /^(IN|CS|CH|HS|\d+)\s/;
294# if (defined $class) {
295# if ($class =~ /\d+/) {
296#
297# }
298# if ($class ne 'IN') {
299# warn "Non-Internet class ($class) records not supported:\n\t$origrec\n";
300# next;
301# }
302# s/(IN|CS|CH|HS)\s+//;
303# } else {
304# $class = 'IN';
305# }
306# my ($type) = /([A-Z-]+)\s/;
307# if (!$reverse_typemap{$type}) {
308# warn "Unknown type $type, skipping\n\t($rec)\n";
309# next;
310# }
311# s/([A-Z-]+)\s+//;
312# chomp;
313
314
[808]315 my $itype = $reverse_typemap{$type};
[817]316 my $rdata = $rec;
[808]317
[812]318 # SOA is the only type that may span multiple lines. Probably. Note even AXFRed zones write multiline SOA records:
319 #@ IN SOA test.example.invalid. test.example.invalid. (2020082500 7200 900 604800 3600)
320 # IN NS olddns.example.com.
321 # IN MX 1 fred.foo.bar.invalid.
322 #foo IN A 192.168.16.45
323 # AXFR'ed zone file gets written as
324 #$ORIGIN .
325 #$TTL 3600 ; 1 hour
326 #example.invalid IN SOA test.example.invalid. test.example.invalid. (
327 # 2020082500 ; serial
328 # 7200 ; refresh (2 hours)
329 # 900 ; retry (15 minutes)
330 # 604800 ; expire (1 week)
331 # 3600 ; minimum (1 hour)
332 # )
333 # NS olddns.example.com.
334 # MX 1 fred.foo.bar.invalid.
335 #$ORIGIN example.invalid.
336 #foo A 192.168.16.45
337
338 if ($type eq 'SOA') {
[813]339 my ($ns, $adminmail) = ($rdata =~ /([\w.]+)\s+([\w.]+)\s+\(/);
[817]340 die "Can't parse gibberish SOAish record: $rec\n" if !$ns;
[813]341 $rdata =~ s/([\w.]+)\s+([\w.]+)\s+\(\s*//;
[812]342
[813]343 # There are probably more efficient ways to do this but the SOA record
344 # format is essentially character based, not line-based.
345 # In theory the SOA serial etc may be spread over up to 5 lines, in any combination.
[812]346
[813]347 # Parse fields from $rdata if present
348 my @soabits;
349 my @soafirst = split /\s+/, $rdata;
350 while (my $f = shift @soafirst) {
351 last if $f !~ /^\d/;
352 push @soabits, $f;
353 }
354
355 # Read more lines if we don't have enough SOA fields filled
356 while (scalar(@soabits) < 5) {
357 my $tmp = <>;
358 $tmp =~ s/^\s*//;
359 my @tmpsoa = split /\s+/, $tmp;
360 while (my $f = shift @tmpsoa) {
361 last if $f !~ /^\d/;
362 push @soabits, $f;
363 }
364 if (scalar(@soabits) == 5) {
365 last;
366 }
367 }
368 } # SOA
369
[808]370 # Quotes may arguably be syntactically required, but they're not actually part of the record data
[813]371 elsif ($type eq 'TXT') {
[808]372 $rdata =~ s/^"//;
373 $rdata =~ s/"$//;
374 }
375
[811]376# temp hack for hosts file
[813]377elsif ($type eq 'A') {
[810]378# if ($amap{$name}) {
379# print "urp: dupe name $name $rdata\n";
380# } else {
[815]381 push @{$amap{$curlabel}}, $rdata;
[810]382# }
[815]383 push @{$namemap{$rdata}}, $curlabel;
[810]384}
[813]385elsif ($type eq 'CNAME') {
[815]386 push @{$cmap{$rdata}}, $curlabel;
[811]387}
[810]388
[808]389no warnings qw(uninitialized);
[810]390#print "parsed: '$name' '$class' '$ttl' '$type'->'$itype' '$rdata'\n";
[808]391#print;
392#;imap IN 900 CNAME deepnet.cx.
393##fixme: not sure how to handle the case where someone leaves off the class.
[810]394 if ($doimport) {
395 my ($code, $msg);
396 if ($rev eq 'n') {
[815]397 ($code,$msg) = $dnsdb->addRec('n', $rev, $zid, \$curlabel, \$itype, \$rdata, $ttl);
[810]398 } else {
[815]399 ($code,$msg) = $dnsdb->addRec('n', $rev, $zid, \$rdata, \$itype, \$curlabel, $ttl);
[810]400 }
401 print "$code: $msg\n";
[809]402 }
[817]403# $i++;
[808]404}
[810]405
406
407#print Dumper \%amap;
[811]408#print Dumper \%namemap;
409#print Dumper \%cmap;
410
[810]411foreach my $n (keys %amap) {
412 foreach my $ip (@{$amap{$n}}) {
413#print "$ip $n\n";
414 push @{$namemap{$ip}}, $n unless grep $n, @{$namemap{$ip}};
415 }
416}
417
[811]418foreach my $c (keys %cmap) {
419 if ($amap{$c}) {
420 print Dumper(\@{$amap{$c}});
421 }
422# print $amap{$c};
[810]423}
[811]424
425# cname targ -> IP
426
427#foreach my $ip (sort keys %namemap) {
428# print "$ip ".join(' ', @{$namemap{$ip}})."\n";
429#}
430
[817]431$dnsdb->{dbh}->rollback;
Note: See TracBrowser for help on using the repository browser.