#!/usr/bin/perl
# Import a BIND zone file
# Note we are not using Net:DNS::ZoneFile, because we want to convert $GENERATE
# directives straight into PTR template or A+PTR template metarecords
##
# Copyright 2020 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/>.
##

use strict;
use warnings;
use Getopt::Long;

use Data::Dumper;

##fixme
use lib '.';
use DNSDB;

my $dnsdb = new DNSDB;
my $doimport = 1;

#print Dumper(\%reverse_typemap);

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

# from tiny-import:  arguably can't use -r, -c is irrelevant.  others useful?
  # -r  rewrite imported files to comment imported records
  # -c  coerce/downconvert A+PTR = records to PTR
  # -l  swallow A+PTR as-is
  # -m  merge PTR and A/AAAA as possible
  # -t  trial mode;  don't commit to DB or actually rewrite flatfile (disables -r)
  # -g  import to specified group (name or ID) instead of group 1

##fixme:  command arguments/flags to set these to alternate values
my $group = 1;
my $status = 1;
my $location = '';
# we'll update this with the actual serial number from the SOA record later
my $serial = time();

my @skipdefs;
my $skipfile;

GetOptions(
	"skip=s" => \@skipdefs,
	"skipfile=s" => \$skipfile,
	"test|dry-run" => sub { $doimport = 0; },
);

my $usage = "usage: bind-import [--skip pattern [--skip pattern2 ...]] [--skipfile file]
    zonename [zonefile]
	--skip    
		Specify a string to skip in the records.  If an IP-like string is
		used, and the zone is a reverse zone, it will also search for the
		octet-reversed form.  Specify multiple times to skip multiple
		different record patterns.
	--skipfile
		A file containing patterns to skip.  Patterns from the file and
		any --skip arguments are merged.
	zonename
		The name of the zone to import.  Required.
	zonefile
		Specify the zone file as an argument.  If not specified, the zone
		data will be read from STDIN.
";

my $zname = shift @ARGV;
my $origzone = $zname;
die $usage if !$zname;

my $zonefile = shift @ARGV;
if(!$zonefile) {
  $zonefile = '&STDIN';
}

my $rev = 'n';
my $zid;
my %foundtypes;

if ($skipfile) {
  if (-f $skipfile) {
    open SKIP, "<$skipfile";
    while (<SKIP>) {
      push @skipdefs, $_;
    }
  } else {
    warn "skipfile $skipfile requested but it doesn't seem to exist.  Continuing.\n";
  }
}

#sub setreplace {
##  print "dbg1: $_[0]\ndbg2: $_[1]\n";
##($_[1] eq '' ? $replace = 1 : $replace = $_[1]);
#  if ($_[1] eq '') {
#    print "no arg value, setting 1\n";
#    $replace = 1;
#  } else {
#    print "arg value $_[1]\n";
#    $replace = $_[1];
#  }
#}


my %amap;
my %namemap;
my %cmap;

# wrap all the DB stuff in eval{}, so the entire thing either succeeds or fails.

eval {

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

##fixme:  this is wrong, BIND zone files are generally complete and we're adding.  merging records is an entire fridge full of worms.
##fixme:  for import, should arguably check for zone *non*existence
  if ($zname =~ /\.arpa\.?$/ || $zname =~ m,^[\d./]+$,) {
    $rev = 'y';
    $zname = _zone2cidr($zname) if $zname =~ /\.arpa\.?$/;
    $zid = $dnsdb->revID($zname,':ANY:');
    if ($zid) {
      die "zone $origzone already present, not merging records\n";
      $zname = new NetAddr::IP $zname;
      $zname = DNSDB::_ZONE($zname, 'ZONE', 'r', '.').($zname->{isv6} ? '.ip6.arpa' : '.in-addr.arpa');
    }
    $zid = $dnsdb->{dbh}->do("INSERT INTO revzones (revnet,group_id,status,default_location,zserial) VALUES (?,?,?,?,?) RETURNING rnds_id",
	undef, ($zname, $group, $status, $location, $serial));

  } else {
print "dbg: forward zone\n";
    $zid = $dnsdb->domainID($zname,':ANY:');
    if ($zid) {
#      die "zone $origzone already present, not merging records\n";
print "dbg: skip add domain\n";
    }
else {
    $zid = $dnsdb->{dbh}->do("INSERT INTO domains (domain,group_id,status,default_location,zserial) VALUES (?,?,?,?,?) RETURNING domain_id",
	undef, ($zname, $group, $status, $location, $serial));
}

  }

  die "error creating zone stub for $zname: ".$dnsdb->{dbh}->errstr if !$zid;


##fixme: should probably make this a named argument so it doesn't get confused with the zone filename
  # still no sane way to expose a human-friendly view tag on the command line.
  my $view = shift @ARGV;
  $view = '' if !$view;

  ##fixme:  retrieve defttl from SOA record
  my $zonettl = 900;
  my $defttl = $zonettl;
  my $origin = "$zname.";	# to append to unqualified names

  # need to spin up a full state machine-ish thing, because BIND zone files are all about context
  # see ch4, p56-72 in the grasshopper book
  my $prevlabel = '';
  my $curlabel = '';

  my $i = 0;

  open ZONEDATA, "<$zonefile";

  while (my $rec = <ZONEDATA>) {
    chomp $rec;
    next if $rec =~ /^\s*$/;
    next if $rec =~ /^\s*;/;	# comments
    next if $rec =~ /^\s*\)/;	# SOA closing (possibly other records too?)
				# arguably should do some more targeted voodoo when parsing the SOA details

##fixme:  use external skiplist
  # skip stale records that have no value
  next if /^ip-192-168-1(12|20)-\d+/;
  next if /ip.add.re.\d+\s*$/;

  $i++;
last if $i > 7;
#print "line $i: ($rec)\n";
    if (my ($macro,$mdetail) = ($rec =~ /^\s*\$(TTL|ORIGIN|INCLUDE|GENERATE)\s+(.+)/) ) {
      # macro sort of thing;  $TTL and $ORIGIN most common.  $INCLUDE is a thing, expect it to be rare in live use tho
      if ($macro eq 'TTL') {
        $mdetail =~ s/\s*;.+$//;
        if ($mdetail =~ /^\d+$/) {
          $defttl = $mdetail;
        } else {
          warn "invalid \$TTL: $rec\n";
        }
      } elsif ($macro eq 'ORIGIN') {
##fixme:  going to skip the stupid case of "$ORIGIN com." and the like that lie
# between . and the root domain we were told we're importing;  anyone using such
# a mess outside the root servers is clearly insane

# $ORIGIN supports cascading/nesting, by watching for fully-qualified names vs partial names.

print "origin ($mdetail)\n";
        if ($mdetail =~ /\.$/) {
          $origin = $mdetail;
        } else {
          # append current origin to unqualified origin
          $origin = "$mdetail.$origin";
        }

#      if ($mdetail eq '.' || $mdetail =~ /$zname\.$/ || $zname =~ /$mdetail\.$/) {
#        $origin = $mdetail;
#      } else {
#        # if we continue, we either use an $ORIGIN that's out of zone, or ignore it and potentially publish incorrect records.
#        die "bad \$ORIGIN: $_\n";
#      }

      }
      elsif ($macro eq 'GENERATE') {
# needs to generate CIDR range(s) as needed to match the start/stop points
      }
    # not handling $INCLUDE or $GENERATE (altho the latter seems to be mostly a less-flexible version of the template types)
      next;
    }

    my $origrec = $rec;

  # leading whitespace indicates "same label as last record"
    if ($rec =~ /^\s/) {
      $curlabel = $prevlabel;
print "  found empty label, using previous label\n";
    } else {
      ($curlabel) = ($rec =~ /^([\w\@_.-]+)\s/);
    }

print "  found '$curlabel'\n";

    # magic name!
    $curlabel = "$zname." if $curlabel eq '@';

    # append $ORIGIN if name is not fully qualified.
    if ($curlabel !~ /\.$/) {
      $curlabel .= ($origin eq '.' ? '.' : ".$origin");
    }
print "  expanded '$curlabel'\n";

# hack pthbptt
#$curlabel =~ s/\.\.$/./;
    # check for zone scope.  skip bad records.
    if ($curlabel !~ /$zname.$/) {
      warn "bad record $origrec, maybe bad \$ORIGIN?\n";
# bweh?  maybe this should die()?
last;
      next;
    }

    # trim the label, if any
    $rec =~ s/^([\w\@_.-]*)\s+//;

#  # records must begin in the first column, no leading whitespace
#  my ($name) = /^([\w\@_.-]+)\s/;

# foo IN A 1.2.3.4
#   IN A 2.3.4.5
# =
# foo.zone. IN A 1.2.3.4
# foo.zone. IN A 2.3.4.5

#  # "empty" label records inherit the previous label
#  # RRs start in the first column by definition, so leading whitespace indicates an inherited label
#  if (/^\s+/) {
#    # fatal error.  if there is no previous label, we can by definition not set
#    # the current label based on it.  this can only happen on the very first
#    # record, following records will *ALWAYS* have a previous label
#    die "bad first record ($_):  no previous label\n" if !$prevlabel;
#    $name = $prevlabel;
#  }

#print "$i ($rec)\n";#\t$curlabel";




#  # append zone name to record name if missing AND not dot-terminated;
#  # this happens automagically for forward zones, but not reverse because Reasons.  (fixme?)
#  # suck up and deal with the error if the dot-termiated name is out of zone;  should be
#  # impossible with valid BIND zone file but...
#  if ($name !~ /\.$/) {
#    $name .= ".$zname" if $name !~ /$zname$/;
#  } else {
#    warn "skipping out-of-zone record:\n\t($_)\n" if $name !~ /$zname\.$/;
#    next;
#  }


    my $nc = 0;
    my $class = 'IN';
    my $type;
    my $ttl;
    my $distance;
    my $weight;
    my $port;
    my $badrec;
    my $curatom = 'class';

    # unpack the class, TTL, and type
    eval {
      for (; $nc < 3; $nc++) {
        my ($atom) = ($rec =~ /^([\w\d.]+)\s/);
        # should be safe?
        last if !$atom;
        last if $type;
#print "nc:$nc: $atom\n";
        if ($atom =~ /^\d+$/) {
          if (defined($ttl)) {
            die "bad record ($origrec)\n";
#            warn "bad record ($origrec)\n";
#            $badrec = 1;
#            last;
          } else {
            if ($curatom ne 'class' && $curatom ne 'ttl') {
              die "bad record ($origrec)\n";
#              warn "bad record ($origrec)\n";
#              $badrec = 1;
#              last;
            }
            $curatom = 'ttl';
            $ttl = $atom;
          }
        }

        elsif ($atom =~ /^IN|CS|CH|HS$/) {
#print "a$nc: d2: atom [$atom]\n        $rec\n" if $i == $debugid;
          if ($atom =~ /CS|CH|HS/) {
            die "unsupported class $atom in record ($origrec)\n";
#            warn "unsupported class $atom in record ($origrec)\n";
#            $badrec = 1;
#            last;
          }
          $curatom = 'class';
          $class = $atom;
        }

        elsif ($atom =~ /^[A-Z]+/) {
#      print "dbg: type $atom\n";
          if ($reverse_typemap{$atom}) {
            $type = $atom;
          } else {
            die "unknown type $atom in record ($origrec)\n";
          }
        }
        $rec =~ s/^$atom\s*//;
      }
    }; # record class/type/TTL parse
    if ($@) {
      warn $@;
      next;
    }

##todo:  BIND conflates a repeated label with repeating the TTL too.  Matter of opinion whether that's really correct or not.
    # set default TTL here so we can detect a TTL in the loop above
    $ttl = $defttl if !defined($ttl);

#next if $badrec;

    $prevlabel = $curlabel;


## by convention the optional TTL leads the optional class, but they're apparently swappable.
#  my ($ttl) = /^(\d+)?\s/;
#  if (defined $ttl) {
#    # TTL may be zero
#    s/(\d+)?\s+//;
#  } else {
#    # Fall back to zone default TTL
#    $ttl = $zonettl;
#  }
#  my ($class) = /^(IN|CS|CH|HS|\d+)\s/;
#  if (defined $class) {
#    if ($class =~ /\d+/) {
#      
#    }
#    if ($class ne 'IN') {
#      warn "Non-Internet class ($class) records not supported:\n\t$origrec\n";
#      next;
#    }
#    s/(IN|CS|CH|HS)\s+//;
#  } else {
#    $class = 'IN';
#  }
#  my ($type) = /([A-Z-]+)\s/;
#  if (!$reverse_typemap{$type}) {
#    warn "Unknown type $type, skipping\n\t($rec)\n";
#    next;
#  }
#  s/([A-Z-]+)\s+//;
#  chomp;


    my $itype = $reverse_typemap{$type};
    my $rdata = $rec;

  # SOA is the only type that may span multiple lines.  Probably.  Note even AXFRed zones write multiline SOA records:
  #@       IN      SOA     test.example.invalid.   test.example.invalid.   (2020082500 7200 900 604800 3600)
  #        IN      NS      olddns.example.com.
  #        IN      MX      1 fred.foo.bar.invalid.
  #foo     IN      A       192.168.16.45
  # AXFR'ed zone file gets written as
  #$ORIGIN .
  #$TTL 3600       ; 1 hour
  #example.invalid         IN SOA  test.example.invalid. test.example.invalid. (
  #                                2020082500 ; serial
  #                                7200       ; refresh (2 hours)
  #                                900        ; retry (15 minutes)
  #                                604800     ; expire (1 week)
  #                                3600       ; minimum (1 hour)
  #                                )
  #                        NS      olddns.example.com.
  #                        MX      1 fred.foo.bar.invalid.
  #$ORIGIN example.invalid.
  #foo                     A       192.168.16.45
  $foundtypes{$type}++;

##fixme:  strip trailing . here?  dnsadmin's normalized internal format omits it, some validation fails or may go funky

    if ($type eq 'SOA') {
      my ($ns, $adminmail) = ($rdata =~ /([\w.]+)\s+([\w.]+)\s+\(/);
      die "Can't parse gibberish SOAish record: $rec\n" if !$ns;
      $rdata =~ s/([\w.]+)\s+([\w.]+)\s+\(\s*//;

      # There are probably more efficient ways to do this but the SOA record
      # format is essentially character based, not line-based.
      # In theory the SOA serial etc may be spread over up to 5 lines, in any combination.

      # Parse fields from $rdata if present
      my @soabits;
      my @soafirst = split /\s+/, $rdata;
      while (my $f = shift @soafirst) {
        last if $f !~ /^\d/;
        push @soabits, $f;
      }

      # Read more lines if we don't have enough SOA fields filled
      while (scalar(@soabits) < 5) {
        my $tmp = <ZONEDATA>;
        $tmp =~ s/^\s*//;
        my @tmpsoa = split /\s+/, $tmp;
        while (my $f = shift @tmpsoa) {
          last if $f !~ /^\d/;
          push @soabits, $f;  
        }
        if (scalar(@soabits) == 5) {
          last;
        }
      }
      my @soavals = ($zid, "$adminmail:$ns", 6, join(':', @soabits), $ttl, $location);
# host = $adminmail:$ns
# val = join(':', @soabits);

      if ($rev eq 'y') {
        $dnsdb->{dbh}->do("UPDATE revzones SET zserial = ? WHERE rdns_id = ?", undef, $soabits[0], $zid);
        $dnsdb->{dbh}->do("INSERT INTO records (rdns_id,host,type,val,ttl,location) VALUES (?,?,?,?,?,?)", undef, @soavals);
      } else {
        $dnsdb->{dbh}->do("UPDATE domains SET zserial = ? WHERE domain_id = ?", undef, $soabits[0], $zid);
        $dnsdb->{dbh}->do("INSERT INTO records (domain_id,host,type,val,ttl,location) VALUES (?,?,?,?,?,?)", undef, @soavals);
      }
#  $dnsdb->{dbh}->do("INSERT INTO records () VALUES ()");
#  next;
#Zfqdn:mname:rname:ser:ref:ret:exp:min:ttl:timestamp:lo
#print "Z$zname:$ns:$adminmail:$soabits[0]:$soabits[1]:$soabits[2]:$soabits[3]:$soabits[4]:$ttl\n";
    } # SOA


    # we're using DNSDB::addrec(), so we'll skip detailed validation of other records.  Most won't need further breakdown

    elsif ($type eq 'A') {
#print "+$curlabel:$rdata:$ttl\n";
    }

    elsif ($type eq 'NS') {
#print "\&$curlabel::$rdata:$ttl\n";
    }

    elsif ($type eq 'CNAME') {
#print "C$curlabel:$rdata:$ttl\n";
    }

    elsif ($type eq 'PTR') {
    }

    elsif ($type eq 'MX') {
      ($distance) = ($rdata =~ /^(\d+)\s+/);
      if (!defined($distance)) {
        warn "malformed MX record: $origrec, skipping\n";
        next;
      }
      $rdata =~ s/^\d+\s+//;
    }

    elsif ($type eq 'TXT') {
      # Quotes may arguably be syntactically required, but they're not actually part of the record data
      $rdata =~ s/^"//;
      $rdata =~ s/"$//;
#print "'$curlabel:$rdata:$ttl\n";
    }

    elsif ($type eq 'RP') {
    }

    elsif ($type eq 'AAAA') {
    }

    elsif ($type eq 'SRV') {
      ($distance, $weight, $port) = ($rdata =~ /^(\d+)\s+(\d+)\s+(\d+)\s+/);
      if ( !defined($distance) || !defined($weight) || !defined($port) ) {
        warn "malformed SRV record: $origrec, skipping\n";
        next;
      }
      $rdata =~ s/^\d+\s+\d+\s+\d+\s+//;
    }

    # basically a dedicated clone of TXT, not sure anything actually looks up type SPF.
    # BIND autogenerates them from SPF TXT records.
    elsif ($type eq 'SPF') {
      # Quotes may arguably be syntactically required, but they're not actually part of the record data
      $rdata =~ s/^"//;
      $rdata =~ s/"$//;
    }

#  elsif ($type eq 'TXT') {
#  elsif ($type eq 'TXT') {

    else {
      warn "unsupported type $type, may not import correctly\n";
    }

no warnings qw(uninitialized);
#print "parsed: '$curlabel' '$class' '$ttl' '$type'->'$itype' '$rdata'\n";
#print;
#;imap   IN      900     CNAME   deepnet.cx.
##fixme:  not sure how to handle the case where someone leaves off the class.
    if ($doimport) {
      my ($code, $msg);
      if ($rev eq 'n') {
        ($code,$msg) = $dnsdb->addRec('n', $rev, $zid, \$curlabel, \$itype, \$rdata, $ttl,
          $location, undef, undef, $distance, $weight, $port);
      } else {
        ($code,$msg) = $dnsdb->addRec('y', $rev, $zid, \$rdata, \$itype, \$curlabel, $ttl,
          $location, undef, undef, $distance, $weight, $port);
      }
      print "$code: $msg\n";
    }
#  $i++;
  }

};
if ($@) {
  warn "Error parsing zonefile: $@\n";
  $dnsdb->{dbh}->rollback;
  exit;
}

#print Dumper \%amap;
#print Dumper \%namemap;
#print Dumper \%cmap;

#foreach my $n (keys %amap) {
#  foreach my $ip (@{$amap{$n}}) {
##print "$ip	$n\n";
#    push @{$namemap{$ip}}, $n unless grep $n, @{$namemap{$ip}};
#  }
#}

#foreach my $c (keys %cmap) {
#  if ($amap{$c}) {
#    print Dumper(\@{$amap{$c}});
#  }
##  print $amap{$c};
#}

# cname targ -> IP

#foreach my $ip (sort keys %namemap) {
#  print "$ip	".join(' ', @{$namemap{$ip}})."\n";
#}

##fixme: might not be sane, addRec() above does a commit() internally.
#$dnsdb->{dbh}->rollback;
$dnsdb->{dbh}->commit;

foreach my $t (keys %foundtypes) {
  print "found $t: $foundtypes{$t}\n";
}