source: trunk/tiny-import.pl@ 364

#!/usr/bin/perl
# dnsadmin shell-based import tool for tinydns flatfiles
##
# $Id: tiny-import.pl 363 2012-07-11 17:35:31Z kdeugau $
# Copyright 2012 Kris Deugau <kdeugau@deepnet.cx>
#
#    This program is free software: you can redistribute it and/or modify
#    it under the terms of the GNU General Public License as published by
#    the Free Software Foundation, either version 3 of the License, or
#    (at your option) any later version.
#
#    This program is distributed in the hope that it will be useful,
#    but WITHOUT ANY WARRANTY; without even the implied warranty of
#    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#    GNU General Public License for more details.
#
#    You should have received a copy of the GNU General Public License
#    along with this program.  If not, see <http://www.gnu.org/licenses/>.
##

# WARNING:  This is NOT a heavy-duty validator;  it is assumed that the data
# being imported is more or less sane.  Only minor structural validation will
# be done to weed out the most broken records.

use strict;
use warnings;

use lib '.';
use DNSDB qw(:ALL);

if (!loadConfig()) {
  warn "Using default configuration;  unable to load custom settings: $DNSDB::errstr";
}

my $code;
my ($dbh,$msg) = connectDB($config{dbname}, $config{dbuser}, $config{dbpass}, $config{dbhost});
initGlobals($dbh) if $dbh;

$dbh->{AutoCommit} = 0;
$dbh->{RaiseError} = 1;

my %cnt;
my @deferred;
my $errstr = '';

foreach my $file (@ARGV) {
  eval {
    import(file => $file);
#    import(file => $file, nosoa => 1);
    $dbh->rollback;
#    $dbh->commit;
  };
  if ($@) {
    print "bleh: $@\n";
die "die harder: $errstr\n";
  }
}

  foreach (keys %cnt) {
    print " $_  $cnt{$_}\n";
  }

exit 0;

sub import {
  our %args = @_;
  my $flatfile = $args{file};
  open FLAT, "<$flatfile";

  our $recsth = $dbh->prepare("INSERT INTO records (domain_id,rdns_id,host,type,val,distance,weight,port,ttl) ".
        " VALUES (?,?,?,?,?,?,?,?,?)");

  my %deleg;

  while (<FLAT>) {
    next if /^#/;
    next if /^\s*$/;
    chomp;
    recslurp($_);
  }

  # Try the deferred records again, once.
  foreach (@deferred) {
  #  print "trying $_ again\n";
    recslurp($_, 1);
  }

print scalar(@deferred)." deferred records in $flatfile\n";

  # Sub for various nonstandard types with lots of pure bytes expressed in octal
  # Takes a tinydns rdata string and count, returns a list of $count bytes as well
  # as trimming those logical bytes off the front of the rdata string.
  sub _byteparse {
    my $src = shift;
    my $count = shift;
    my @ret;
    for (my $i = 0; $i < $count; $i++) {
      if ($$src =~ /^\\/) {
        # we should have an octal bit
        my ($tmp) = ($$src =~ /^(\\\d{3})/);
        $tmp =~ s/\\/0/;
        push @ret, oct($tmp);
        $$src =~ s/^\\\d{3}//;
      } else {
        # we seem to have a byte expressed as an ASCII character
        my ($tmp) = ($$src =~ /^(.)/);
        push @ret, ord($tmp);
        $$src =~ s/^.//;
      }
    }
    return @ret;
  }

  # Convert octal-coded bytes back to something resembling normal characters, general case
  sub _deoctal {
    my $targ = shift;
    while ($$targ =~ /\\(\d{3})/) {
      my $sub = chr(oct($1));
      $$targ =~ s/\\$1/$sub/g;
    }
  }

  sub _rdata2string {
    my $rdata = shift;
    my $tmpout = '';
    while ($rdata) {
      my $bytecount = 0;
      if ($rdata =~ /^\\/) {
        ($bytecount) = ($rdata =~ /^(\\\d{3})/);
        $bytecount =~ s/\\/0/;
        $bytecount = oct($bytecount);
        $rdata =~ s/^\\\d{3}//;
      } else {
        ($bytecount) = ($rdata =~ /^(.)/);
        $bytecount = ord($bytecount);
        $rdata =~ s/^.//;
      }
      my @tmp = _byteparse(\$rdata, $bytecount);
      foreach (@tmp) { $tmpout .= chr($_); }
##fixme:  warn or fail on long (>256?  >512?  >321?) strings
    }
    return $tmpout;
  }

  sub _rdata2hex {
    my $rdata = shift;
    my $tmpout = '';
    while ($rdata) {
      my $byte = '';
      if ($rdata =~ /^\\/) {
        ($byte) = ($rdata =~ /^(\\\d{3})/);
        $byte =~ s/\\/0/;
        $tmpout .= sprintf("%0.2x", oct($byte));
        $rdata =~ s/^\\\d{3}//;
      } else {
        ($byte) = ($rdata =~ /^(.)/);
        $tmpout .= sprintf("%0.2x", ord($byte));
        $rdata =~ s/^.//;
      }
    }
    return $tmpout;
  }


  sub recslurp {
    my $rec = shift;
    my $nodefer = shift || 0;

    $errstr = $rec;  # this way at least we have some idea what went <splat>

    if ($rec =~ /^=/) {
      $cnt{APTR}++;

##fixme:  do checks like this for all types
      if ($rec !~ /^=(?:\*|\\052)?[a-z0-9\._-]+:[\d\.]+:\d*/i) {
        print "bad A+PTR $rec\n";
        return;
      }
      my ($host,$ip,$ttl,$stamp,$loc) = split /:/, $rec, 5;
      $host =~ s/^=//;
      $host =~ s/\.$//;
      $ttl = 0 if !$ttl;
      $stamp = '' if !$stamp;
      $loc = '' if !$loc;
      $loc = '' if $loc =~ /^:+$/;
      my $fparent = DNSDB::_hostparent($dbh, $host);
      my ($rparent) = $dbh->selectrow_array("SELECT rdns_id FROM revzones WHERE revnet >> ?", undef, ($ip));
      if ($fparent && $rparent) {
        $recsth->execute($fparent, $rparent, $host, 65280, $ip, 0, 0, 0, $ttl);
      } else {
        push @deferred, $rec unless $nodefer;
        #  print "$tmporig deferred;  can't find both forward and reverse zone parents\n";
      }

    } elsif ($rec =~ /^C/) {
      $cnt{CNAME}++;

      my ($host,$targ,$ttl,$stamp,$loc) = split /:/, $rec, 5;
      $host =~ s/^C//;
      $host =~ s/\.$//;
      $host =~ s/^\\052/*/;
      $ttl = 0 if !$ttl;
      $stamp = '' if !$stamp;
      $loc = '' if !$loc;
      $loc = '' if $loc =~ /^:+$/;
      if ($host =~ /\.arpa$/) {
        ($code,$msg) = DNSDB::_zone2cidr($host);
        my ($rparent) = $dbh->selectrow_array("SELECT rdns_id FROM revzones WHERE revnet >> ?", undef, ($msg));
        $recsth->execute(0, $rparent, $targ, 5, $msg->addr, 0, 0, 0, $ttl);

##fixme:  automagically convert manually maintained sub-/24 delegations
#       my ($subip, $zone) = split /\./, $targ, 2;
#       ($code, $msg) = DNSDB::_zone2cidr($zone);
#       push @{$deleg{"$msg"}{iplist}}, $subip;
#print "$msg $subip\n";

      } else {
        my $fparent = DNSDB::_hostparent($dbh, $host);
        if ($fparent) {
          $recsth->execute($fparent, 0, $host, 5, $targ, 0, 0, 0, $ttl);
        } else {
          push @deferred, $rec unless $nodefer;
          #  print "$tmporig deferred;  can't find parent zone\n";
        }
      }

    } elsif ($rec =~ /^\&/) {
      $cnt{NS}++;

      my ($zone,$ip,$ns,$ttl,$stamp,$loc) = split /:/, $rec, 6;
      $zone =~ s/^\&//;
      $zone =~ s/\.$//;
      $ns =~ s/\.$//;
      $ns = "$ns.ns.$zone" if $ns !~ /\./;
      $ttl = 0 if !$ttl;
      $stamp = '' if !$stamp;
      $loc = '' if !$loc;
      $loc = '' if $loc =~ /^:+$/;
      if ($zone =~ /\.arpa$/) {
        ($code,$msg) = DNSDB::_zone2cidr($zone);
        my ($rparent) = $dbh->selectrow_array("SELECT rdns_id FROM revzones WHERE revnet >>= ?", undef, ("$msg"));
##fixme, in concert with the CNAME check for same;  automagically
# create "delegate" record instead for subzone NSes:  convert above to use = instead of >>=
#  ($rparent) = $dbh->selectrow_array("SELECT rdns_id FROM revzones WHERE revnet >> ?", undef, ("$msg"))
#       if !$rparent;
        if ($rparent) {
          $recsth->execute(0, $rparent, $ns, 2, $msg, 0, 0, 0, $ttl);
        } else {
          push @deferred, $rec unless $nodefer;
        }
      } else {
        my $fparent = DNSDB::_hostparent($dbh, $zone);
        if ($fparent) {
          $recsth->execute($fparent, 0, $zone, 2, $ns, 0, 0, 0, $ttl);
          $recsth->execute($fparent, 0, $ns, 2, $ip, 0, 0, 0, $ttl) if $ip;
        } else {
          push @deferred, $rec unless $nodefer;
        }
      }

    } elsif ($rec =~ /^\^/) {
      $cnt{PTR}++;

      my ($rip,$host,$ttl,$stamp,$loc) = split /:/, $rec, 5;
      $rip =~ s/^\^//;
      $rip =~ s/\.$//;
      $ttl = 0 if !$ttl;
      $stamp = '' if !$stamp;
      $loc = '' if !$loc;
      $loc = '' if $loc =~ /^:+$/;
      my $rparent;
      if (my ($i, $z) = ($rip =~ /^(\d+)\.(\d+-(?:\d+\.){4}in-addr.arpa)$/) ) {
        ($code,$msg) = DNSDB::_zone2cidr($z);
        # Exact matches only, because we're in a sub-/24 delegation
##fixme:  flag the type of delegation (range, subnet-with-dash, subnet-with-slash)
# somewhere so we can recover it on export.  probably best to do that in the revzone data.
        ($rparent) = $dbh->selectrow_array("SELECT rdns_id FROM revzones WHERE revnet = ?", undef, ("$msg"));
        $z =~ s/^[\d-]+//;
        ($code,$msg) = DNSDB::_zone2cidr("$i.$z");      # Get the actual IP and normalize
      } else {
        ($code,$msg) = DNSDB::_zone2cidr($rip);
        ($rparent) = $dbh->selectrow_array("SELECT rdns_id FROM revzones WHERE revnet >> ?", undef, ("$msg"));
      }
      if ($rparent) {
        $recsth->execute(0, $rparent, $host, 12, $msg->addr, 0, 0, 0, $ttl);
      } else {
        push @deferred, $rec unless $nodefer;
      }

    } elsif ($rec =~ /^\+/) {
      $cnt{A}++;

      my ($host,$ip,$ttl,$stamp,$loc) = split /:/, $rec, 5;
      $host =~ s/^\+//;
      $host =~ s/\.$//;
      $host =~ s/^\\052/*/;
      $ttl = 0 if !$ttl;
      $stamp = '' if !$stamp;
      $loc = '' if !$loc;
      $loc = '' if $loc =~ /^:+$/;

      my $domid = DNSDB::_hostparent($dbh, $host);
      if ($domid) {
        $recsth->execute($domid, 0, $host, 1, $ip, 0, 0, 0, $ttl);
      } else {
        push @deferred, $rec unless $nodefer;
      }

    } elsif ($rec =~ /^Z/) {
      $cnt{SOA}++;

      my ($zone,$master,$contact,$serial,$refresh,$retry,$expire,$minttl,$ttl,$stamp,$loc) = split /:/, $rec, 11;
      $zone =~ s/^Z//;
      $zone =~ s/\.$//;
      $master =~ s/\.$//;
      $contact =~ s/\.$//;
      $ttl = 0 if !$ttl;
      $stamp = '' if !$stamp;
      $loc = '' if !$loc;
      $loc = '' if $loc =~ /^:+$/;
      if ($zone =~ /\.arpa$/) {
        ($code,$msg) = DNSDB::_zone2cidr($zone);
        $dbh->do("INSERT INTO revzones (revnet,group_id,status) VALUES (?,1,1)", undef, ($msg));
        my ($rdns) = $dbh->selectrow_array("SELECT currval('revzones_rdns_id_seq')");
        $recsth->execute(0, $rdns, "$contact:$master", 6, "$refresh:$retry:$expire:$minttl", 0, 0, 0, $ttl);
      } else {
        $dbh->do("INSERT INTO domains (domain,group_id,status) VALUES (?,1,1)", undef, ($zone));
        my ($domid) = $dbh->selectrow_array("SELECT currval('domains_domain_id_seq')");
        $recsth->execute($domid, 0, "$contact:$master", 6, "$refresh:$retry:$expire:$minttl", 0, 0, 0, $ttl);
      }

    } elsif ($rec =~ /^\@/) {
      $cnt{MX}++;

      my ($zone,$ip,$host,$dist,$ttl,$stamp,$loc) = split /:/, $rec, 7;
      $zone =~ s/^\@//;
      $zone =~ s/\.$//;
      $zone =~ s/^\\052/*/;
      $host =~ s/\.$//;
      $host = "$host.mx.$zone" if $host !~ /\./;
      $ttl = 0 if !$ttl;
      $stamp = '' if !$stamp;
      $loc = '' if !$loc;
      $loc = '' if $loc =~ /^:+$/;

# note we don't check for reverse domains here, because MX records don't make any sense in reverse zones.
# if this really ever becomes an issue for someone it can be expanded to handle those weirdos

      # allow for subzone MXes, since it's perfectly legitimate to simply stuff it all in a single parent zone
      my $domid = DNSDB::_hostparent($dbh, $zone);
      if ($domid) {
        $recsth->execute($domid, 0, $zone, 15, $host, $dist, 0, 0, $ttl);
        $recsth->execute($domid, 0, $host, 1, $ip, 0, 0, 0, $ttl) if $ip;
      } else {
        push @deferred, $rec unless $nodefer;
      }

    } elsif ($rec =~ /^'/) {
      $cnt{TXT}++;

      my ($fqdn, $rdata, $ttl, $stamp, $loc) = split /:/, $rec, 5;
      $fqdn =~ s/^'//;
      $fqdn =~ s/^\\052/*/;
      _deoctal(\$rdata);
      $ttl = 0 if !$ttl;
      $stamp = '' if !$stamp;
      $loc = '' if !$loc;
      $loc = '' if $loc =~ /^:+$/;

      if ($fqdn =~ /\.arpa$/) {
        ($code,$msg) = DNSDB::_zone2cidr($fqdn);
        my ($rparent) = $dbh->selectrow_array("SELECT rdns_id FROM revzones WHERE revnet >> ?", undef, ($msg));
        $recsth->execute(0, $rparent, $rdata, 16, "$msg", 0, 0, 0, $ttl);
      } else {
        my $domid = DNSDB::_hostparent($dbh, $fqdn);
        if ($domid) {
          $recsth->execute($domid, 0, $fqdn, 16, $rdata, 0, 0, 0, $ttl);
        } else {
          push @deferred, $rec unless $nodefer;
        }
      }

    } elsif ($rec =~ /^\./) {
      $cnt{NSASOA}++;

      my ($fqdn, $ip, $ns, $ttl, $stamp, $loc) = split /:/, $rec, 6;
      $fqdn =~ s/^\.//;
      $fqdn =~ s/\.$//;
      $ns =~ s/\.$//;
      $ns = "$ns.ns.$fqdn" if $ns !~ /\./;
      $ttl = 0 if !$ttl;
      $stamp = '' if !$stamp;
      $loc = '' if !$loc;
      $loc = '' if $loc =~ /^:+$/;

      if ($fqdn =~ /\.arpa$/) {
        ($code,$msg) = DNSDB::_zone2cidr($fqdn);
        my ($rdns) = $dbh->selectrow_array("SELECT rdns_id FROM revzones WHERE revnet = ?", undef, ($msg));
        if (!$rdns) {
          $errstr = "adding revzone $msg";
          $dbh->do("INSERT INTO revzones (revnet,group_id,status) VALUES (?,1,1)", undef, ($msg));
          ($rdns) = $dbh->selectrow_array("SELECT currval('revzones_rdns_id_seq')");
# this would probably make a lot more sense to do hostmaster.$config{admindomain}
          $recsth->execute(0, $rdns, "hostmaster.$fqdn:$ns", 6, "16384:2048:1048576:2560", 0, 0, 0, "2560");
        }
        $recsth->execute(0, $rdns, $ns, 2, "$msg", 0, 0, 0, $ttl);
##fixme:  (?)  implement full conversion of tinydns . records?
# -> problem:  A record for NS must be added to the appropriate *forward* zone, not the reverse
#$recsth->execute(0, $rdns, $ns, 1, $ip, 0, 0, 0, $ttl)
# ...  auto-A-record simply does not make sense in reverse zones.  Functionally
# I think it would work, sort of, but it's a nasty mess and anyone hosting reverse
# zones has names for their nameservers already.
# Even the auto-nameserver-fqdn comes out...  ugly.

      } else {
        my ($domid) = $dbh->selectrow_array("SELECT domain_id FROM domains WHERE lower(domain) = lower(?)",
                undef, ($fqdn));
        if (!$domid) {
          $errstr = "adding domain $fqdn";
          $dbh->do("INSERT INTO domains (domain,group_id,status) VALUES (?,1,1)", undef, ($fqdn));
          ($domid) = $dbh->selectrow_array("SELECT currval('domains_domain_id_seq')");
          $recsth->execute($domid, 0, "hostmaster.$fqdn:$ns", 6, "16384:2048:1048576:2560", 0, 0, 0, "2560");
        }
        $recsth->execute($domid, 0, $fqdn, 2, $ns, 0, 0, 0, $ttl);
        $recsth->execute($domid, 0, $ns, 1, $ip, 0, 0, 0, $ttl) if $ip;
      }


    } elsif ($rec =~ /^\%/) {
      $cnt{VIEWS}++;

    } elsif ($rec =~ /^:/) {
      $cnt{NCUST}++;
# Big section.  Since tinydns can publish anything you can encode properly, but only provides official
# recognition and handling for the core common types, this must deal with the leftovers.
# :fqdn:type:rdata:ttl:time:loc

      my (undef, $fqdn, $type, $rdata, $ttl, $stamp, $loc) = split /:/, $rec, 7;
      $fqdn =~ s/\.$//;
      $fqdn =~ s/^\\052/*/;
      $ttl = 0 if !$ttl;
      $stamp = '' if !$stamp;
      $loc = '' if !$loc;
      $loc = '' if $loc =~ /^:+$/;

      if ($type == 33) {
        # SRV
        my ($prio, $weight, $port, $target) = (0,0,0,0);

        my @tmp = _byteparse(\$rdata, 2);
        $prio = $tmp[0] * 256 + $tmp[1];
        @tmp = _byteparse(\$rdata, 2);
        $weight = $tmp[0] * 256 + $tmp[1];
        @tmp = _byteparse(\$rdata, 2);
        $port = $tmp[0] * 256 + $tmp[1];

        $rdata =~ s/\\\d{3}/./g;
        ($target) = ($rdata =~ /^\.(.+)\.$/);
# hmm.  the above *should* work, but What If(TM) we have ASCII-range bytes
# representing the target's fqdn part length(s)?  axfr-get doesn't seem to,
# probably because dec. 33->63 includes most punctuation and all the numbers
#  while ($rdata =~ /(\\\d{3})/) {
#    my $cnt = $1;
#    $rdata =~ s/^$cnt//;
#    $cnt =~ s/^\\/0/;
#    $cnt = oct($cnt);
#    my ($seg) = ($rdata =~ /^(.{$cnt})/);
#    $target .=
#  }

        my $domid = DNSDB::_hostparent($dbh, $fqdn);
        if ($domid) {
          $recsth->execute($domid, 0, $fqdn, 33, $target, $prio, $weight, $port, $ttl) if $domid;
        } else {
          push @deferred, $rec unless $nodefer;
        }

      } elsif ($type == 28) {
        # AAAA
        my @v6;

        for (my $i=0; $i < 8; $i++) {
          my @tmp = _byteparse(\$rdata, 2);
          push @v6, sprintf("%0.4x", $tmp[0] * 256 + $tmp[1]);
        }
        my $val = NetAddr::IP->new(join(':', @v6));

        my $fparent = DNSDB::_hostparent($dbh, $fqdn);
        if ($fparent) {
          $recsth->execute($fparent, 0, $fqdn, 28, $val->addr, 0, 0, 0, $ttl);
        } else {
          push @deferred, $rec unless $nodefer;
        }

      } elsif ($type == 16) {
        # TXT
        my $txtstring = _rdata2string($rdata);

        if ($fqdn =~ /\.arpa$/) {
          ($code,$msg) = DNSDB::_zone2cidr($fqdn);
          my ($rparent) = $dbh->selectrow_array("SELECT rdns_id FROM revzones WHERE revnet >> ?", undef, ($msg));
          if ($rparent) {
            $recsth->execute(0, $rparent, $txtstring, 16, "$msg", 0, 0, 0, $ttl);
          } else {
            push @deferred, $rec unless $nodefer;
          }
        } else {
          my $domid = DNSDB::_hostparent($dbh, $fqdn);
          if ($domid) {
            $recsth->execute($domid, 0, $fqdn, 16, $txtstring, 0, 0, 0, $ttl);
          } else {
            push @deferred, $rec unless $nodefer;
          }
        }

      } elsif ($type == 17) {
        # RP
        my ($email, $txtrec) = split /\\000/, $rdata;
        $email =~ s/\\\d{3}/./g;
        $email =~ s/^\.//;
        $txtrec =~ s/\\\d{3}/./g;
        $txtrec =~ s/^\.//;

        # these might actually make sense in a reverse zone...  sort of.
        if ($fqdn =~ /\.arpa$/) {
          ($code,$msg) = DNSDB::_zone2cidr($fqdn);
          my ($rparent) = $dbh->selectrow_array("SELECT rdns_id FROM revzones WHERE revnet >> ?", undef, ($msg));
          if ($rparent) {
            $recsth->execute(0, $rparent, "$email $txtrec", 17, "$msg", 0, 0, 0, $ttl);
          } else {
            push @deferred, $rec unless $nodefer;
          }
        } else {
          my $domid = DNSDB::_hostparent($dbh, $fqdn);
          if ($domid) {
            $recsth->execute($domid, 0, $fqdn, 17, "$email $txtrec", 0, 0, 0, $ttl);
          } else {
            push @deferred, $rec unless $nodefer;
          }
        }

      } elsif ($type == 44) {
        # SSHFP
        my $sshfp = _byteparse(\$rdata, 1);
        $sshfp .= " "._byteparse(\$rdata, 1);
        $sshfp .= " "._rdata2hex($rdata);

        # these do not make sense in a reverse zone, since they're logically attached to an A record
        my $domid = DNSDB::_hostparent($dbh, $fqdn);
        if ($domid) {
          $recsth->execute($domid, 0, $fqdn, 44, $sshfp, 0, 0, 0, $ttl);
        } else {
          push @deferred, $rec unless $nodefer;
        }

      } else {
        # ... uhhh, dunno
      }

    } else {
      $cnt{other}++;
      print " $_\n";
    }
  }

  close FLAT;
}