#!/usr/bin/perl -w

=head1 NAME

check_domain

=head1 BESCHREIBUNG

Nagios-kompatibles Script zum Monitoring von Domains

=cut

use strict;
use utf8;
use warnings;

# $Id: check_domain,v 1.28 2005/06/20 09:13:27 fany Exp fany $

use Fcntl qw(:DEFAULT :flock);
use FindBin;
use Getopt::Long qw(GetOptions);
use Net::DNS::Resolver::Recurse;
use Time::HiRes qw(time);

use lib do { $FindBin::Bin =~ /^(.*)/; $1 };
use FreezeThaw qw(freeze thaw);
use noris::NetSaint;

use constant HINTS => qw(
  198.41.0.4
  192.228.79.201
  192.33.4.12
  128.8.10.90
  192.203.230.10
  192.5.5.241
  192.112.36.4
  128.63.2.53
  192.36.148.17
  192.58.128.30
  193.0.14.129
  198.32.64.12
  202.12.27.33
);

=pod

=encoding utf8

=head1 SYNOPSE

    check_domain -status-file-prefix /tmp/check_domain_ \
                 dns.noris.net,dns.noris.de,dns.noris.ch unf.ug \
                 -any-request www=CNAME:unf.ug.

Ein nicht zu einer Option gehriges Argument wird als I<Liste_von_DNS-Servern>
betrachtet, wenn es mindestens ein Komma enthlt.
(Um nur einen DNS-Server anzugeben, kann an dessen Namen einfach ein Komma
angehngt werden, z. B. "sun.of-a-bit.ch,".) Alle anderen Argumente werden als
zu berprfende Domain angesehen.

=head1 NOTWENDIGE ARGUMENTE

=over 4

=item -status-file-prefix Pfad-/Dateiprfix

gibt den Pfad zu den Dateien an, die das Script benutzt, um sich zu merken,
seit wann welche Inkonsistenz bereits besteht (vgl. unten).
Pro Domain wird eine eigene Datei angelegt; der Domainname wird dabei direkt an
den Pfad angehngt.

=back

=head1 OPTIONEN

=over 4

=item -debug

Debug-Modus (fr DNS-Abfragen) einschalten.
Durch mehrfache Verwendung der Option kann der Debug-Modus erhht werden.

=item -any-request Sub-Domain=RRs

es wird ein ANY-Request fr die angegebene Sub-Domain durchgefhrt.
Als Wert hinter dem Gleichheitszeichen mssen dabei mit Kommata getrennt die
erwarteten Records angegeben werden.
Das RDATA muss vom Record-Typ dabei durch einen Doppelpunkt getrennt werden;
Whitespace innerhalb des RDATAs ist ggf. ebenfalls durch Unterstiche zu
ersetzen.
Beispiel:

 --any-request www=A:62.128.1.80,MX:10_mx.noris.net.,MX:10_mx.noris.de.

Die Liste muss vollstndig sein.
Jegliche Abweichung gilt als kritischer Fehler.

Die Option kann mehrfach verwendet werden, um mehrere Sub-Domains zu berwachen.

=item -nocheck-delegation

die bei den root-Servern beginnende berprfung der Delegation der Domain
deaktivieren

=item -nocompare-ns-records

berprfung, ob die NS-Records der autoritativen Zone mit der beim jeweiligen
NIC eingetragenen bereinstimmen (vgl. unten), deaktivieren

=item -delay-warnings Sekunden

Bei minderschweren Inkonsistenzen (vgl. unten) wird erst nach berschreiten der
hier (in Sekunden; Default: 2520, also 42 Minuten) angegebenen Zeitgrenze eine
I<Warnung> erzeugt.

=item -log Dateiname

hier kann der Name einer Log-Datei bergeben werden; dort wird dann bei jedem
Script-Start und -Ende jeweils ein einzeiliger Eintrag angehngt, aus dem auch
die auf der Kommandozeile bergebenen Argumente hervorgehen.

=item -rrd Dateiname

hier kann der (Datei-)Name einer Round Robin Database (RRD) angegeben werden.
Es wird dann fr jeden autoritativen Server die Zeit, die zur Abfrage bentigt
wurde, in der RRD festgehalten, unter dem FQDN als Variablenname, wobei die
Punkte allerdings durch Unterstriche ersetzt werden (mssen), damit RRD das
frisst.

=item -tcp-timeout Sekunden

setzt den TCP-Timeout des L<Net::DNS::Resolver::Recurse> (in Sekunden).
(Default: 15 Sekunden)

=item -udp-timeout Sekunden

setzt den UDP-Timeout des L<Net::DNS::Resolver::Recurse> (in Sekunden).
(Default: 15 Sekunden)

=item -wait4answers Sekunden

gibt die Anzahl der Sekunden an, die (bei mehreren Domains: jeweils) auf
Antworten der autoritativen DNS-Server gewartet werden soll. (Default: 8 s)

=item -help

=item -?

um (nur) diese Dokumentation anzeigen zu lassen

=back

=head1 BEGRIFFLICHKEITEN

Das Plugin unterscheidet zwei Arten von Strungen:

=over 4

=item schwere Strung

Beim Auftreten einer I<schweren Strung> wird sofort Status I<Critical>
gemeldet.

=item minderschwere Inkonsistenz

Wird eine I<minderschwere Inkonsistenz> beobachtet, wird zunchst nur der
Beobachtungszeitpunkt in der Status-Datei vermerkt.
Erst, wenn diese Inkonsistenz mindestens so lange wie die angegebene Zeitgrenze
anhlt, wird eine I<Warnung> ausgegeben.

=back

=head1 FUNKTIONSWEISE

Die Liste der bergebenen Argumente wird von vorne nach hinten durchlaufen, so
dass jede I<Liste_von_DNS-Servern> fr alle nach dieser und der nchsten
entsprechenden Liste angegebenen Domains gilt.

Folgendes Prfprogramm wird fr jede angegebene Domain durchlaufen:

=over 4

=cut

my $argv = join '|', $0, @ARGV;

GetOptions(
    'any-request=s'        => \our %AnyRequest,
    'check-delegation!'    => \( our $CheckDelegation = 1 ),
    'compare-ns-records!'  => \( our $CompareNsRecords = 1 ),
    'debug+'               => \our $Debug,
    'delay-warnings=i'     => \( our $DelayWarnings = 2520 ),
    'help|?'               => \our $Help,
    'log=s'                => \our $Log,
    'rrd=s'                => \our $Rrd,
    'status-file-prefix=s' => \our $StatusFilePrefix,
    'tcp-timeout=f'        => \( our $TCP_Timeout = 15 ),
    'udp-timeout=f'        => \( our $UDP_Timeout = 15 ),
    'wait4answers=f'       => \( our $Wait4Answers = 8 ),
) or exit 1;

exec perldoc => -F => $0 or die "exec('perldoc -F $0'): $!\n" if $Help;

sub delayed_warning(\%\%$$) {
    my ( $oldstatus, $newstatus, $netsaint, $type ) = @_;
    my $seconds = $^T - ( $newstatus->{$type} = $oldstatus->{$type} || $^T );
    $netsaint->atleast('Warning')
      unless defined $DelayWarnings && $seconds < $DelayWarnings;
    $seconds;
}

sysopen my $log, $Log, O_APPEND | O_CREAT | O_WRONLY if defined $Log;
print $log localtime() . " Started: $argv\n" if $log;

my $NetSaint = new noris::NetSaint;

die "A -status-file-prefix must be given.\n" unless defined $StatusFilePrefix;

my $resolver = new Net::DNS::Resolver;
my $rr       = new Net::DNS::Resolver::Recurse;
$rr->hints(HINTS);
if ($Debug)       { $_->debug($Debug)             for $resolver, $rr }
if ($TCP_Timeout) { $_->tcp_timeout($TCP_Timeout) for $resolver, $rr }
if ($UDP_Timeout) { $_->udp_timeout($UDP_Timeout) for $resolver, $rr }

my ( %ns, $unknown );

for my $domain (@ARGV) {
    if ( $domain =~ y/,// ) {
        %ns = map +( $_ => undef ), map split(/\s*,\s*/), lc $domain;
    }
    elsif (
        not sysopen my $status_fh,
        ( my $status_file = $StatusFilePrefix . $domain ),
        O_RDWR | O_CREAT
      )
    {
        $NetSaint->update( Critical =>
              qq(Cannot open status-file "$status_file" for $domain: $!) );
    }
    elsif ( not flock $status_fh, LOCK_EX ) {
        $NetSaint->update(
            Critical => qq(Cannot get exclusive lock for "$status_file": $!) );
    }
    else {
        my %oldstatus;
        if ( -s $status_fh ) {
            local $/;
            %oldstatus = thaw <$status_fh>;
            seek $status_fh, 0, 0 or die "seek: $!";
            truncate $status_fh, 0 or die "truncate: $!";
        }
        my %newstatus;

=pod

=item *

Zunchst wird ermittelt, welche NameServer laut NS-Records fr die Domain
zustndig sind.
(Um Einflsse lokaler Fehlkonfigurationen auszuschlieen, wird bei den
root-NameServern begonnen.)
Schlgt diese Abfrage fehl, gilt dies als schwere Strung, und es finden keine
weiteren berprfungen fuer diese Domain statt.

=cut

        my @ns;

        unless ($CheckDelegation) { @ns = sort keys %ns }
        elsif ( !defined( my $ns = $rr->query_dorecursion( $domain, 'NS' ) ) ) {
            $NetSaint->update(
                Critical => "error resolving NS records for $domain: "
                  . $rr->errorstring );
        }
        elsif ( !( my @answer = $ns->answer ) ) {
            $NetSaint->update( Critical => "no NS records for $domain found" );
        }
        else {

=pod

=item *

Befindet sich unter diesen mindestens ein nicht in der aktuellen (vgl. oben)
I<Liste_von_DNS-Servern> enthaltener Server, liegt eine schwere Strung vor.

=cut

            my @wrong_ns;
            exists $ns{$_}
              or push @wrong_ns, $_
              for @ns = sort map lc $_->nsdname, @answer;
            $NetSaint->update(
                Critical => "unexpected NS record"
                  . ( @wrong_ns != 1 && 's' )
                  . " for $domain: "
                  . join ',',
                @wrong_ns
            ) if @wrong_ns;
        }

        if (@ns) {
            my %records;

=pod

=item *

Im zweiten Schritt wird (je) ein C<ANY>-Request fr den Domain-Namen an die oben
ermittelten, fr die jeweilige Domain zustndigen DNS-Server selbst geschickt.

=cut

            my $none;
            {
                my ( %socket, %time );
                for (@ns) {
                    unless ( $resolver->nameservers($_) ) {
                        $NetSaint->update( Critical => "$_ (NS for $domain): "
                              . $resolver->errorstring );
                    }
                    elsif ( not my $socket =
                        $resolver->bgsend( $domain, 'ANY' ) )
                    {
                        $NetSaint->update(
                            Critical => "bgsend('$domain','ANY') to $_: "
                              . $resolver->errorstring );
                    }
                    else {
                        $time{$_} = time if defined $Rrd;
                        $socket{$_} = $socket;
                    }
                }

=pod

=item *

Eine minderschwere Inkonsistenz liegt vor, falls sich ein angesprochener
Server nicht fr autoritativ erklrt (d. h. ohne aa-Flag antwortet); in diesem
Fall finden fr die fragliche Domain auf diesem Server keine weiteren
berprfungen statt.

=cut

                my $timeout = time + $Wait4Answers if $Wait4Answers;
                while ( keys %socket ) {
                    my $rvec = '';
                    vec( $rvec, fileno $_, 1 ) = 1 for values %socket;
                    last
                      unless my $selected = select $rvec, undef, undef,
                      $timeout - time;
                    die "select(): $!\n" if $selected < 0;
                    for ( keys %socket ) {
                        next unless vec $rvec, fileno $socket{$_}, 1;
                        unless ( my $answer =
                            $resolver->bgread( delete $socket{$_} ) )
                        {
                            $NetSaint->update( Critical =>
                                  "DNS reply from $_ (NS for $domain): "
                                  . $resolver->errorstring );
                        }
                        elsif ( $answer->header->tc ) {
                            $NetSaint->add_message(
                                "truncated answer for $domain from $_");
                            delayed_warning %oldstatus, %newstatus, $NetSaint,
                              "tc_$_";
                        }
                        elsif ( not $answer->header->aa ) {
                            $NetSaint->add_message(
                                "$_ is not authoritative for $domain");
                            delayed_warning %oldstatus, %newstatus, $NetSaint,
                              "no_aa_$_";
                        }
                        else {
                            $time{$_} = [ int $time{$_}, time - $time{$_} ]
                              if defined $Rrd;
                            my %rr;
                            push @{ $rr{ $_->type } }, $_ for $answer->answer;
                            while ( my ( $type, $rr ) = each %rr ) {
                                push @{
                                    $records{$type}{
                                        join ',', sort map lc $_->rdatastr, @$rr
                                      }
                                  },
                                  $_;
                            }

=pod

=item *

Liefert einer der autoritativen Server mehr oder weniger als einen C<SOA>-Record
zurck, liegt eine schwere Strung vor.

=cut

                            $NetSaint->update( Critical => "$_ returned "
                                  . @{ $rr{SOA} }
                                  . " SOA records for $domain" )
                              if @{ $rr{SOA} } != 1;
                        }
                    }
                }

=pod

=item *

Antwortet I<keiner> der autoritativen Server, wird dies als schwere Strung
betrachtet.

=cut

                if ( keys %socket == @ns ) {
                    $none = 1;
                    $NetSaint->update(
                            Critical => 'none of the authoritative servers ('
                          . join( ',', @ns )
                          . ") for $domain answered" );
                }
                else {

=pod

=item *

Hat nur ein Teil der Server nicht geantwortet, gilt dies als minderschwere
Inkonsistenz.

=cut

                    for ( keys %socket ) {
                        $NetSaint->add_message("no answer from $_");
                        delayed_warning %oldstatus, %newstatus, $NetSaint,
                          "timeout_$_";
                    }
                }

                if ( keys %time ) {
                    my %update;
                    while ( my ( $server, $time ) = each %time ) {
                        next unless ref $time;
                        ( my $ds = $server ) =~ y/./_/;
                        push @{ $update{ $time->[0] }[0] }, $ds;
                        push @{ $update{ $time->[0] }[1] }, $time->[1];
                    }
                    require RRDs;
                    for ( sort { $a <=> $b } keys %update ) {
                        RRDs::update(
                            $Rrd,
                            -t => join( ':', @{ $update{$_}[0] } ),
                            join ':', $_, @{ $update{$_}[1] }
                        );
                        if ( my $error = RRDs::error() ) {
                            $NetSaint->update( Unknown =>
                                  "Problem with RRD update for $domain $error"
                            );
                            ++$unknown;
                        }
                    }
                }
            }

=pod

=item *

Liefern alle autoritativen Server identische NS-Eintrge, wird -- sofern dieser
Test nicht durch B<--nocompare-ns-records> ausgeschaltet wurde -- berprft, ob
diese mit den oben ermittelten bereinstimmen.
Nicht-bereinstimmungen werden als minderschwere Inkonsistenz betrachtet.

=cut

            if (   $CompareNsRecords
                && keys %{ $records{NS} } == 1
                && ( my $ns_aa = ( keys %{ delete $records{NS} } )[0] ) ne
                ( my $ns = join ',', map "$_.", @ns ) )
            {
                $NetSaint->add_message(
                        "NS records in zone $domain ($ns_aa) differ from "
                      . ( $CheckDelegation ? 'real' : 'expected' )
                      . " NS records ($ns)" );
                delayed_warning %oldstatus, %newstatus, $NetSaint, 'ns';
            }

=pod

=item *

Es wird dann fr alle verbliebenen Record-Typen berprft, ob die Antworten
aller autoritativen Server jeweils bereinstimmen.
Nicht-bereinstimmungen gelten als minderschwere Inkonsistenz.

=cut

            while ( my ( $type, $records ) = each %records ) {
                if ( keys %$records > 1 ) {
                    my $seconds = delayed_warning %oldstatus, %newstatus,
                      $NetSaint, $type;
                    $NetSaint->add_message(
"$type inconsistency for $domain since $seconds seconds: "
                          . join ' vs. ',
                        map "$_\@" . join( '/', @{ $records->{$_} } ),
                        keys %$records
                    );
                }
            }

            unless ($none) {
                while ( my ( $name, $records ) = each %AnyRequest ) {
                    my @records = split ',', $records;
                    $name .= '.' if length $name;
                    $name .= $domain;
                    unless (
                        defined(
                            my $any = $rr->query_dorecursion( $name, 'ANY' )
                        )
                      )
                    {
                        $NetSaint->update(
                            Critical => "error during ANY request for $name: "
                              . $rr->errorstring );
                    }
                    elsif ( !( my @answer = $any->answer ) ) {
                        $NetSaint->update( Critical =>
                              "ANY request for $name returned no records" );
                    }
                    else {
                        my %record;
                        @record{@records} = (1) x @records;
                        for (@answer) {
                            ( my $record = $_->type . ':' . $_->rdatastr ) =~
                              y/ /_/;
                            next if defined delete $record{$record};
                            $NetSaint->update( Critical =>
                                  "Got unexpected record $record for $name" );
                        }
                        if ( keys %record ) {
                            $NetSaint->update(
                                Critical => 'Missing record'
                                  . ( keys %record > 1 && 's' )
                                  . " for $name: "
                                  . join ', ',
                                sort keys %record
                            );
                        }
                    }
                }
            }
        }

        print $status_fh freeze %newstatus;
        close $status_fh
          or $NetSaint->update( Warning =>
              qq(Error closing status-file "$status_file" for $domain: $!) );
    }
}

$NetSaint->message('No errors detected.') unless $NetSaint->message;
$NetSaint->status('OK') if $NetSaint->status eq 'Unknown' && !$unknown;

print $log localtime() . " Finished: $argv\n" if $log;

=pod

=back

=head1 AUTOR

 Martin H. Sluka <fany@noris.net>
 fr die noris network AG, RT#74887, RT#180027

=cut

__END__
package my::Net::DNS::Resolver::Recurse;
use base 'Net::DNS::Resolver::Recurse';

our $AUTOLOAD;

sub AUTOLOAD {
    my $self = shift;
    ( my $method = $AUTOLOAD ) =~ s/^.*:://;
    if ($::Debug) {
        my ( $package, $filename, $line ) = caller;
        print STDERR
          qq(->$method(@_) called from $package (line $line of "$filename").\n);
    }
    $method = "SUPER::$method";
    $self->$method(@_);
}

