#!/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 $dryrun = 0;

#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" => \$dryrun,
);

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.
	--dry-run
		Do everything except finalize the import
	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>) {
      chomp;
      push @skipdefs, $_;
    }
    close SKIP;
  } 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";
#print "dbg: skip add revzone\n";
#      $zname = new NetAddr::IP $zname;
#      $zname = DNSDB::_ZONE($zname, 'ZONE', 'r', '.').($zname->{isv6} ? '.ip6.arpa' : '.in-addr.arpa');
    }
    ($zid) = $dnsdb->{dbh}->selectrow_array("INSERT INTO revzones (revnet,group_id,status,default_location,zserial) VALUES (?,?,?,?,?) RETURNING rnds_id",
	undef, ($zname, $group, $status, $location, $serial));

  } else {
    $zid = $dnsdb->domainID($zname,':ANY:');
    if ($zid) {
#      die "zone $origzone already present, not merging records\n";
#print "dbg: skip add domain\n";
    }
#    ($zid) = $dnsdb->{dbh}->selectrow_array("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

    # check skiplist.  do this early since it's (mostly) a simple string match against the raw record line
    my $skipflag = 0;
    foreach (@skipdefs) {
      if ($rec =~ /\Q$_\E/) {
        $skipflag = 1;
        # might want to do something with the skipped records someday
      }
    }
    next if $skipflag;


$i++;
#last if $i > 17;
#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') {
        # $ORIGIN supports cascading/nesting, by watching for fully-qualified names vs partial names.
        if ($mdetail =~ /\.$/) {
          $origin = $mdetail;
        } else {
          # append current origin to unqualified origin
          $origin = "$mdetail.$origin";
        }
      }
      elsif ($macro eq 'GENERATE') {
# needs to generate CIDR range(s) as needed to match the start/stop points
      }
##fixme: should arguably handle $INCLUDE
      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/);
    }

    # yay for special cases
    $origin = '' if $origin eq '.';

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

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

    # append $ORIGIN if name is not fully qualified.
    if ($curlabel !~ /\.$/) {
      $curlabel .= ".$origin";
    }

    # 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+//;

    # now that we've collected and trimmed off the record's label, unpack the class, TTL, and type.
    # class and TTL may be omitted, and may appear in either class,TTL or TTL,class order.
    my $nc = 0;
    # we don't actually use these but we have to recognize them
    my $class = 'IN';
    # not preset as we need to detect whether it's present in the record
    my $ttl;
    my $type;
    my $badrec;
    my $curatom = 'class';
    eval {
      for (; $nc < 3; $nc++) {
        last if $type;	# short-circuit if we've got a type, further data is record-specific.
        my ($atom) = ($rec =~ /^([\w\d.]+)\s/);
        # should be safe?
        last if !$atom;
        if ($atom =~ /^\d+$/) {
          if (defined($ttl)) {
            # we already have a TTL, so another all-numeric field is invalid.
            die "bad record ($origrec)\n";
          } else {
            if ($curatom ne 'class' && $curatom ne 'ttl') {
              die "bad record ($origrec)\n";
            }
            $curatom = 'ttl';
            $ttl = $atom;
          }
        }
        elsif ($atom =~ /^IN|CS|CH|HS$/) {
          if ($atom =~ /CS|CH|HS/) {
            die "unsupported class $atom in record ($origrec)\n";
          }
          $curatom = 'class';
          $class = $atom;
        }
        elsif ($atom =~ /^[A-Z\d-]+/) {
          # check against dnsadmin's internal list of known DNS types.
          if ($reverse_typemap{$atom}) {
            $type = $atom;
          } else {
            die "unknown type $atom in record ($origrec)\n";
          }
          $curatom = 'type';
        }
        $rec =~ s/^$atom\s*//;
      }
    }; # record class/type/TTL loop
    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;


    # Just In Case we need the original rdata after we've sliced off more pieces
    my $rdata = $rec;
    $prevlabel = $curlabel;

    # part of the record data, when present
    my $distance;
    my $weight;
    my $port;

    my $itype = $reverse_typemap{$type};


# See RFC1035 and successors for the canonical zone file format reference.  We'll
# ignore a number of edge cases because they're quite horrible to parse.
# Of particular note is use of () to continue entries across multiple lines.  Use
# outside of SOA records is quite rare, although some compliant zone file
# *writers* may use it on TXT records.
# We'll also ignore the strict interpretation in SOA records in favour of spotting
# the more standard pattern where the SOA serial, refresh, retry, expire, and minttl
# numbers are in ():

#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)
#                                )

    $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*//;

      # 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);
      }
      # skip insert at end of loop;  SOA records are not handled by DNSDB::addRec()
      next;
    } # 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";
    }

##fixme:  need to dig out a subtransaction widget or extract a core of addRec() that doesn't dbh->commit(), so --dry-run works
#    unless ($dryrun) {
      my ($code, $msg);

# swap curlabel/rdata for revzones, because our internal metastorage only knows about "host" and "val"
# keep the originals Just In Case(TM)
$curlabel =~ s/\.$//;	# dnsadmin doesn't store trailing dots
my $inshost = $curlabel;
my $insval = $rdata;
if ($rev eq 'y') {
  $inshost = $rdata;
  $insval = $curlabel;
}
print "dbg: maybeip next ($insval)\n";
my $addr = NetAddr::IP->new($insval) if DNSDB::_maybeip(\$insval);
my $fields;
my @vallist;

($code,$msg) = $validators{$itype}($dnsdb, defrec => 'n', revrec => $rev, id => $zid,
	host => \$inshost, rectype => \$itype, val => \$insval, addr => $addr,
	dist => \$distance, port => \$port, weight => \$weight,
	fields => \$fields, vallist => \@vallist);

# Add standard common fields
$fields .= "host,type,val,ttl,".DNSDB::_recparent('n',$rev);
push @vallist, ($inshost,$itype,$insval,$ttl,$zid);

my $vallen = '?'.(',?'x$#vallist);

print "INSERT INTO records ($fields) VALUES ($vallen);\n".join("','", @vallist)."\n";

#      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" if $code ne 'OK';
#    }
#  $i++;
  }

  if ($dryrun) {
    $dnsdb->{dbh}->rollback;
  } else {
    $dnsdb->{dbh}->commit;
  }
};
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";
}