#!/usr/bin/perl
# Quick utility to use post-import to convert great huge piles of
# A+PTR records to single A+PTR template records
##
# $Id: compact-recs.pl 890 2025-06-24 16:41:37Z kdeugau $
# Copyright 2013-2022,2025 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;

# Taint-safe (ish) voodoo to push "the directory the script is in" into @INC.
# See https://secure.deepnet.cx/trac/dnsadmin/ticket/80 for more gory details on how we got here.
use File::Spec ();
use File::Basename ();
my $path;
BEGIN {
    $path = File::Basename::dirname(File::Spec->rel2abs($0));
    if ($path =~ /(.*)/) {
        $path = $1;
    }
}
use lib $path;

use DNSDB;

usage() if !$ARGV[1];

sub usage {
  die qq(usage:  compact-recs.pl netblock pattern [--replace [record id]]
    netblock   the CIDR block to define the A+PTR template on
    pattern    the pattern to define the new A+PTR template with, and
               to match A+PTR records within the netblock for deletion
    --replace  Optional argument to update an existing template if found.
               A record ID can be specified to match a particular record,
               or 'all' to forcibly remove all but one in the event of
               multiple records.  If multiple records are found but neither
               'all' or a specific record ID is specified, an error will be
               returned and nothing will be changed since there is no
               guarantee of which record might be replaced.

	OR
	compact-recs.pl --batch patternfile
    patternfile should be a file containing a list of netblock-pattern
    pairs, whitespace separated.  --replace is ignored in this mode.

    A PTR template record will be created instead of an A+PTR template
    if the forward zone specified in the template is not present in
    the database.

    WARNING:  Multiple runs may result in duplicate template records.
);
}

my $batchmode = 0;
my $replace = 0;
my $tmpl_msg = '';

GetOptions("batch" => \$batchmode,
	"replace:s" => \&setreplace );

sub setreplace {
  if ($_[1] eq '') {
    $replace = -1;
  } else {
    $replace = $_[1];
  }
}

if ($replace && $replace !~ /^(all|-?\d+)$/) {
  warn "Invalid --replace argument $replace:\n";
  usage();
}

my $dnsdb = new DNSDB or die "Couldn't create DNSDB object: ".$DNSDB::errstr."\n";
my $dbh = $dnsdb->{dbh};

my $code;

# get userdata for log
($dnsdb->{logusername}, undef, undef, undef, undef, undef, $dnsdb->{logfullname}) = getpwuid($<);
$dnsdb->{logfullname} =~ s/,//g;
$dnsdb->{loguserid} = 0;	# not worth setting up a pseudouser the way the RPC system does
$dnsdb->{logusername} = $dnsdb->{logusername}."/compact-recs.pl";
$dnsdb->{logfullname} = ($dnsdb->{logfullname} ? $dnsdb->{logfullname}."/compact-recs.pl" : $dnsdb->{logusername});

if ($batchmode) {
  # --replace not safe for --batch.  could arguably support an in-file flag someday?
  if ($replace) {
    $replace = 0;
    warn "--replace not compatible with --batch.  Attempting to continue.\n";
  }
  open NBLIST, "<$ARGV[0]";
  while (<NBLIST>) {
    next if /^#/;
    next if /^\s*$/;
    s/^\s*//;
    squashem(split(/\s+/));
  }
} else {
  my $cidr = new NetAddr::IP $ARGV[0];
  usage() if !$cidr;
  squashem($cidr, $ARGV[1]);
}

exit 0;


sub squashem {
  my $cidr = shift;
  my $patt = shift;

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

  my ($zonecidr,$zone,$ploc) = $dbh->selectrow_array(
      "SELECT revnet,rdns_id,default_location FROM revzones WHERE revnet >>= ?",
      undef, ($cidr) );
  if (!$zone) {
    warn "$cidr is not within a zone currently managed here.\n";
    return;
  }
  my $soa = $dnsdb->getSOA('n', 'y', $zone);
  my $dparent = $dnsdb->_hostparent($patt) || 0;
  # Automatically choose new type as A+PTR template if the new pattern's
  # domain is managed in this instance, or PTR template if not
  my $newtype = ($dparent ? 65283 : 65282);

  my ($tmplcount) = $dbh->selectrow_array("SELECT count(*) FROM records WHERE rdns_id = ? AND ".
      "(type=65282 OR type=65283) AND val = ?", undef, ($zone, $cidr) );
  if ($tmplcount && !$replace) {
    # Template(s) found, --replace not set
    print "One or more templates found for $cidr, use --replace [record_id],".
        " --replace all, or clean up manually.\n";
    return;
  } elsif ($tmplcount > 1 && ($replace eq '0' || $replace eq '-1')) {
    # Multiple templates found, --replace either not set (==0) or no argument provided (==-1)
    print "Multiple templates found matching $cidr but no record ID specified with".
        " --replace.  Use --replace with a record ID, use --replace all, or clean up".
        " manually.\n";
    return;
  }

  print "Converting PTR and A+PTR records in $cidr matching $patt to single $typemap{$newtype} record\n";
  my $delcnt = 0;

  eval {
    # First, clean up the records that match the template.
    my $getsth = $dbh->prepare("SELECT record_id,host,val FROM records ".
        "WHERE (type = 12 OR type > 65000) AND inetlazy(val) << ? AND rdns_id = ?");
    my $delsth = $dbh->prepare("DELETE FROM records WHERE record_id = ?");
    $getsth->execute($cidr, $zone);
    my $i = 0;
    while (my ($id,$host,$val) = $getsth->fetchrow_array) {
      my $cmp = $patt;
      # skip existing template within the new template's range
      next if $val =~ m{/\d+$};
      if ($cmp =~ /\%-?c/) {
        # Determine "nth host" index value of $val for %c and %-c
        my $possible = new NetAddr::IP $val;
        my $valindex = $possible - $cidr;
        DNSDB::_template4_expand(\$cmp, $val, \$cidr, $valindex);
      } else {
        DNSDB::_template4_expand(\$cmp, $val, \$cidr);
      }
      $delsth->execute($id) if $cmp eq $host;
      $delcnt++ if $cmp eq $host;
    }

    my $template_modified = 0;

    if ($replace) {
      if ($replace eq 'all') {
        # clear any templates with the same CIDR, and add a new one
        $dbh->do("DELETE from records WHERE rdns_id = ? AND (type=65282 OR type=65283) AND val = ?", undef, ($zone, $cidr) );
        $dbh->do("INSERT INTO records (domain_id, rdns_id, host, type, val, ttl, location) VALUES (?,?,?,?,?,?,?)",
            undef, ($dparent, $zone, $patt, $newtype, $cidr, $soa->{minttl}, $ploc) );
        $template_modified = 1;
        $tmpl_msg = ", replaced $tmplcount template records";
      } else {
        if ($replace =~ /^\d+$/) {
          # $replace == [id] -> replace that record ID, error if it doesn't exist or isn't
          # a template for the specified CIDR.  Arguably some stretch on the latter.
          my ($rechost,$recval,$rectype) = $dbh->selectrow_array(
              "SELECT host,val,type,record_id FROM records WHERE record_id = ?",
              undef, $replace);
          if (($rectype == 65282 || $rectype == 65283) && $recval eq $cidr) {
            # Do the update if the record specified matches is a suitable template
            $dbh->do("UPDATE records SET host = ?, type = ?, val = ? WHERE record_id = ?",
                undef, ($patt, $newtype, $cidr, $replace) );
            $template_modified = 1;
            $tmpl_msg = ", replaced an existing template record";
          } else {
            # Specified record ID isn't a template record, or doesn't match $cidr, or both
            die "Specified record ID isn't a template for $cidr, skipping:\n".
                "  $replace found:  $rechost $typemap{$rectype} $recval\n";
          }
        } else {
          # $replace == -1 -> replace/update template iff one template is present
          #   (should have errored out earlier if multiple templates are present)
          my ($rechost,$recval,$rectype,$recid) = $dbh->selectrow_array(
              "SELECT host,val,type,record_id FROM records WHERE rdns_id = ? AND (type=65282 OR type=65283) AND val = ?",
              undef, ($zone, $cidr) );
          if ($recid) {
            # Do the update if we've found an existing template with the same CIDR
            $dbh->do("UPDATE records SET host = ?, type = ?, val = ? WHERE record_id = ?",
                undef, ($patt, $newtype, $cidr, $recid) );
            $template_modified = 1;
            $tmpl_msg = ", replaced an existing template record";
          } else {
            $dbh->do("INSERT INTO records (domain_id, rdns_id, host, type, val, ttl, location) VALUES (?,?,?,?,?,?,?)",
                undef, ($dparent, $zone, $patt, $newtype, $cidr, $soa->{minttl}, $ploc) );
            $template_modified = 1;
          }
        } # $replace -> [id] or $replace == -1
      } # $replace <> 'all'
    } else {
      # $replace == 0 (not set), just insert the new template
      $dbh->do("INSERT INTO records (domain_id, rdns_id, host, type, val, ttl, location) VALUES (?,?,?,?,?,?,?)",
	undef, ($dparent, $zone, $patt, $newtype, $cidr, $soa->{minttl}, $ploc) );
      $template_modified = 1;
    }

    if ($template_modified) {
      my %logdata = (rdns_id => $zone, domain_id => $dparent, group_id => 1,
          entry => "A+PTR and/or PTR records in $cidr matching $patt replaced by $typemap{$newtype} record for $cidr");
      $dnsdb->_updateserial(%logdata);
      $dnsdb->_log(%logdata);
      $dbh->commit;
    } else {
      # no need to do push out a null update that just bumps the serial on the zone(s)
      $dbh->rollback;
    }

  };
  if ($@) {
    print "Error(s) encountered: $@\n";
    $dbh->rollback;
    return;
  }
  print " complete (removed $delcnt PTR/A+PTR records";
  print $tmpl_msg;
  print ")\n";
} # squashem ()