#!/usr/pkg/bin/perl
#
# $Id: dnscheck.pl 721 2009-03-04 15:27:27Z calle $
#
# Copyright (c) 2007 .SE (The Internet Infrastructure Foundation).
#                    All rights reserved.
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions
# are met:
# 1. Redistributions of source code must retain the above copyright
#    notice, this list of conditions and the following disclaimer.
# 2. Redistributions in binary form must reproduce the above copyright
#    notice, this list of conditions and the following disclaimer in the
#    documentation and/or other materials provided with the distribution.
#
# THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
# IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
# WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
# DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
# GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
# INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER
# IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
# OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
# IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
#
######################################################################

use warnings;
use strict;
use utf8;
use 5.01001;

use Getopt::Long;
use DNSCheck;
use Time::HiRes qw[time];

my %changed;
my %dropped;
my %added;

my $debug;
my $dc;
my $config;
my %flagdomain;
my $filename;
my $tsig;
my $dig;
my @servers;
my $domain;

my $newsuffix    = '.new';
my $backupsuffix = '.bak';

sub setup {
    GetOptions( "debug" => \$debug );

    print "Running in debug mode.\n" if $debug;

    $dc     = DNSCheck->new;
    $config = $dc->config->get( "zonediff" );
    foreach my $domain ( @{ $config->{flagdomain} } ) {
        $flagdomain{exist}{$domain} = 1;
        print "Flag domain: $domain\n" if $debug;
    }

    $filename = $config->{datafile};
    $tsig     = $config->{tsig};
    $tsig =~ s/ TSIG /:/;
    $dig     = $config->{dig};
    @servers = @{ $config->{servers} };
    $domain  = $config->{domain};

    if ( $debug ) {
        print "Data file: $filename\n";
        print "TSIG: $tsig\n";
        print "dig: $dig\n";
        print "Servers: @servers\n";
        print "Domain: $domain\n";
    }
}

sub fetch_new_zone {
    my $success;

    foreach my $server ( @servers ) {
        my $start = time;
        print "Trying server $server...\n" if $debug;
        print "$dig axfr $domain \@$server -y $tsig > $filename$newsuffix\n"
          if $debug;
        my $res = system( "$dig axfr $domain \@$server -y $tsig > $filename$newsuffix" );
        printf( "Transfer ended after %0.2f seconds.\n", time() - $start );
        $res >>= 8;
        if ( $res == 0 ) {
            print "Got file.\n" if $debug;
            $success = 1;
            last;
        }
    }

    unless ( -e $filename ) {
        print "$filename missing.\n";
        if ( $success ) {
            print "Moving just fetched file to $filename and exiting.\n";
            rename $filename . $newsuffix, $filename;
            exit( 1 );
        }
    }

    my $newsize = -s $filename . $newsuffix;
    my $oldsize = -s $filename;
    my $ratio   = $newsize / $oldsize;

    if ( $ratio < 0.83 ) {
        die "New file is more than 20% smaller than old file. Exiting.\n";
    }
    else {
        printf( "Ratio of new file size to old file size: %0.3f\n", $ratio )
          if $debug;
    }
}

sub switch_files_around {
    rename $filename, $filename . $backupsuffix
      or die "Failed to rename save file to backup file: $!\n";
    print "$filename renamed to $filename$backupsuffix\n" if $debug;
    rename $filename . $newsuffix, $filename
      or die "Failed to rename new file to save file: $!\n";
    print "$filename$newsuffix renamed to $filename\n" if $debug;
}

sub check_for_flagdomains {
    foreach my $name ( keys %{ $flagdomain{exist} } ) {
        unless ( $flagdomain{new}{$name} ) {
            die "Flag domain $name missing from new file. Exiting.\n";
        }
        unless ( $flagdomain{old}{$name} ) {
            die "Flag domain $name missing from old file. Exiting.\n";
        }
    }
}

sub line_parse {
    my ( $line ) = @_;

    my ( $name, $type, $rest ) = $line =~ m/
                ^
                ([-.a-z0-9]+)\. # Name
                \s+
                \d+           # TTL
                \s+
                IN
                \s+
                ((?:NS)|(?:DS)|(?:A)|(?:AAAA))     # Type
                \s+
                (.+)          # Rest
                $
                /x;
    if ( $name ) {
        if ( $type eq 'A' or $type eq 'AAAA' ) {
            return ( $rest, $type, $name );
        }
        else {
            return ( $name, $type, $rest );
        }
    }
    else {
        return;
    }
}

sub extract {
    my ( $ary, $type ) = @_;

    return join '', map { $_->[2] }
      grep { $_->[1] eq $type } sort { $a->[2] cmp $b->[2] } @$ary;
}

sub compare {
    my ( $n, $o ) = @_;
    my $name = $n->[0][0];

    my $nns   = extract( $n, 'NS' );
    my $ons   = extract( $o, 'NS' );
    my $nds   = extract( $n, 'DS' );
    my $ods   = extract( $o, 'DS' );
    my $na    = extract( $n, 'A' );
    my $oa    = extract( $o, 'A' );
    my $naaaa = extract( $n, 'AAAA' );
    my $oaaaa = extract( $o, 'AAAA' );

    $changed{$name} .= 'NS '   if $nns ne $ons;
    $changed{$name} .= 'DS '   if $nds ne $ods;
    $changed{$name} .= 'A '    if $na ne $oa;
    $changed{$name} .= 'AAAA ' if $naaaa ne $oaaaa;

    my %oldns = map { $_->[2], 1 } grep { $_->[1] eq 'NS' } @$o;
    foreach my $new ( map { $_->[2], 1 } grep { $_->[1] eq 'NS' } @$n ) {
        delete $oldns{$new};
    }
    foreach my $ns ( keys %oldns ) {
        $dropped{$name}{$ns} = 1;
    }
}

sub process {
    my %res;

    open my $new, '<', $filename . $newsuffix
      or die "Failed to open $filename$newsuffix: $!\n";
    open my $old, '<', $filename
      or die "Failed ot open $filename: $!\n";
    my $nline = '';
    my $oline = '';

    print "Datafiles opened.\n" if $debug;

    while ( defined( $nline ) or defined( $oline ) ) {
        my @n;
        my @o;

        $nline = <$new>;
        chomp( $nline ) if $nline;
        $oline = <$old>;
        chomp( $oline ) if $oline;

        if ( defined( $nline ) and ( @n = line_parse( $nline ) ) ) {
            $flagdomain{new}{ $n[0] } = 1 if $flagdomain{exist}{ $n[0] };
            $res{$nline} += 1;
            if ( defined( $res{$nline} ) and $res{$nline} == 0 ) {
                delete $res{$nline};
            }
        }

        if ( defined( $oline ) and ( @o = line_parse( $oline ) ) ) {
            $flagdomain{old}{ $o[0] } = 1 if $flagdomain{exist}{ $o[0] };
            $res{$oline} -= 1;
            if ( defined( $res{$oline} ) and $res{$oline} == 0 ) {
                delete $res{$oline};
            }
        }
    }

    print "Data files read (" . scalar( keys %res ) . " entries retained).\n"
      if $debug;

    my %old;
    my %new;
    while ( my ( $k, $v ) = each %res ) {
        my ( $name, $type, $data ) = line_parse( $k );

        if ( $v == 1 ) {
            push @{ $new{$name} }, [ $name, $type, $data ];
        }
        elsif ( $v == -1 ) {
            push @{ $old{$name} }, [ $name, $type, $data ];
        }
        else {
            print "Error: $v => $k\n";
        }
    }
    %res = ();

    foreach my $zone ( keys %new ) {
        if ( !$old{$zone} ) {
            $added{$zone} = 1;
        }
        else {
            compare( $new{$zone}, $old{$zone} );
        }
    }
    print "Retained data compared.\n" if $debug;
}

sub get_source_id {
    my $dbh = $dc->dbh;

    $dbh->do( q[INSERT IGNORE INTO source (name) VALUES (?)], undef, $config->{sourcestring} );
    my @res = $dbh->selectrow_array( q[SELECT id FROM source WHERE name = ?], undef, $config->{sourcestring} );

    print "Got source id " . $res[0] . "\n" if $debug;
    return $res[0];
}

sub save_to_database {
    my $dbh       = $dc->dbh;
    my $source_id = get_source_id();

    my $drop_sth  = $dbh->prepare( q[INSERT IGNORE INTO delegation_history (domain, nameserver) VALUES (?,?)] );
    my $queue_sth = $dbh->prepare( q[INSERT INTO queue (priority,domain,source_id,source_data) VALUES (?,?,?,?)] );

    foreach my $name ( keys %added ) {
        $queue_sth->execute( 3, $name, $source_id, 'NEW' );
        print "Queue: $name NEW\n" if $debug;
    }

    foreach my $name ( keys %changed ) {
        $queue_sth->execute( 3, $name, $source_id, $changed{$name} );
        print "Queue: $name " . $changed{$name} . "\n" if $debug;
    }

    foreach my $zone ( keys %dropped ) {
        foreach my $ns ( keys %{ $dropped{$zone} } ) {
            $drop_sth->execute( $zone, $ns );
            print "Delegation History: $zone $ns\n" if $debug;
        }
    }
}

setup();
fetch_new_zone();
process();
check_for_flagdomains();
save_to_database();
switch_files_around();

=head1 NAME

dnscheck-zonediff - Tool to periodically detect changes in a zone

=head1 SYNOPSIS

dnscheck-zonediff [--debug]

Options:

 --debug               Make the script print out some progress and result information.

=head1 EXPLANATION

This script calls out to L<dig> to download a zonefile using a cryptographic
signature. The zone, the signature, the servers to ask, the file to save the
data in, the database to put insert differences into and so on is all
specified in L<config.yaml> (or the corresponding site_config).

This script relies heavily on the output from L<dig> nor changing its format
and to be in properly sorted order.
