#!/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 gehöriges Argument wird als I<Liste_von_DNS-Servern>
betrachtet, wenn es mindestens ein Komma enthält.
(Um nur einen DNS-Server anzugeben, kann an dessen Namen einfach ein Komma
angehängt werden, z. B. "sun.of-a-bit.ch,".) Alle anderen Argumente werden als
zu überprüfende Domain angesehen.

=head1 NOTWENDIGE ARGUMENTE

=over 4

=item -status-file-prefix Pfad-/Dateipräfix

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 angehängt.

=back

=head1 OPTIONEN

=over 4

=item -any-request Sub-Domain=RRs

es wird ein ANY-Request für die angegebene Sub-Domain durchgeführt.
Als Wert hinter dem Gleichheitszeichen müssen 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 vollständig 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 Überprüfung der Delegation der Domain
deaktivieren

=item -nocompare-ns-records

Überprüfung, 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 angehängt, aus dem auch
die auf der Kommandozeile übergebenen Argumente hervorgehen.

=item -resolver-option Name=Wert

zum Konfigurieren der verwendeten L<Net::DNS::Resolver> (und
L<Net::DNS::Resolver::Recurse>)

Defaults: retrans=1 retry=3 tcp_timeout=15 udp_timeout=15

Beispiel:

    -resolver-option debug=1

=item -rrd Dateiname

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

=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 Störungen:

=over 4

=item schwere Störung

Beim Auftreten einer I<schweren Störung> wird sofort Status I<Critical>
gemeldet.

=item minderschwere Inkonsistenz

Wird eine I<minderschwere Inkonsistenz> beobachtet, wird zunächst nur der
Beobachtungszeitpunkt in der Status-Datei vermerkt.
Erst, wenn diese Inkonsistenz mindestens so lange wie die angegebene Zeitgrenze
anhält, 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> für alle nach dieser und der nächsten
entsprechenden Liste angegebenen Domains gilt.

Folgendes Prüfprogramm wird für jede angegebene Domain durchlaufen:

=over 4

=cut

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

our %ResolverOption =
  ( retrans => 1, retry => 3, tcp_timeout => 15, udp_timeout => 15 );

GetOptions(
    'any-request=s'        => \our %AnyRequest,
    'check-delegation!'    => \( our $CheckDelegation = 1 ),
    'compare-ns-records!'  => \( our $CompareNsRecords = 1 ),
    'delay-warnings=i'     => \( our $DelayWarnings = 2520 ),
    'help|?'               => \our $Help,
    'log=s'                => \our $Log,
    'resolver-option=f%'   => \%ResolverOption,
    'rrd=s'                => \our $Rrd,
    'status-file-prefix=s' => \our $StatusFilePrefix,
    'wait4answers=f'       => \( our $Wait4Answers = 8 ),

    # nur für Abwärtskompatibilität:
    'debug+'        => sub { ++$ResolverOption{debug} },
    'tcp-timeout=f' => sub { $ResolverOption{tcp_timeout} = $_[1] },
    'udp-timeout=f' => sub { $ResolverOption{udp_timeout} = $_[1] },
) 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 = Net::DNS::Resolver->new(%ResolverOption);
( my $rr = Net::DNS::Resolver::Recurse->new(%ResolverOption) )->hints(HINTS);

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;

=item *

Zunächst wird ermittelt, welche NameServer laut NS-Records für die Domain
zuständig sind.
(Um Einflüsse lokaler Fehlkonfigurationen auszuschließen, wird bei den
root-NameServern begonnen.)
Schlägt diese Abfrage fehl, gilt dies als schwere Störung, und es finden keine
weiteren Überprüfungen 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 Störung 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 für den Domain-Namen an die oben
ermittelten, für die jeweilige Domain zuständigen 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 für autoritativ erklärt (d. h. ohne aa-Flag antwortet); in diesem
Fall finden für die fragliche Domain auf diesem Server keine weiteren
Überprüfungen 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;
                  Socket: for ( keys %socket ) {
                        next unless vec $rvec, fileno $socket{$_}, 1;
                        my $answer = $resolver->bgread( delete $socket{$_} );

                        # Ticket 21445398: Bei Bedarf Fallback auf TCP;
                        # das dann halt nicht parallelisiert:
                        {

                            # Man könnte wohl auch ->send_tcp() aufrufen,
                            # aber das ist nicht Teil der offiziellen API.
                            my $usevc = $resolver->usevc;
                            $resolver->usevc(1);
                            $answer = $resolver->send( $domain, 'ANY' )
                              if $answer->header->tc;
                            $resolver->usevc($usevc);
                        }

                        unless ($answer) {
                            $NetSaint->update( Critical =>
                                  "DNS reply from $_ (NS for $domain): "
                                  . $resolver->errorstring );
                            next Socket;
                        }
                        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
zurück, liegt eine schwere Störung 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 Störung
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-Einträge, wird -- sofern dieser
Test nicht durch B<--nocompare-ns-records> ausgeschaltet wurde -- überprüft, 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 für alle verbliebenen Record-Typen überprüft, 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 BEKANNTE PROBLEME

L<Net::DNS::Resolver::Recurse> ist -- jedenfalls noch in Rev. 750 aus
L<Net::DNS> 0.65 -- relativ doof.
Insbesondere verwendet er keinen wirklichen Cache, und er versucht es hartnäckig
bei nicht erreichbaren DNS-Servern, bevor er alternative anspricht.
Details s. Ticket 498085.

Workaround: Wir verwenden ein möglichst kleines C<retrans>-Intervall.

=head1 AUTOR

 Martin H. Sluka <fany@noris.net>
 für die noris network AG,
 vgl. Tickets #74887, #180027, #498085

=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(@_);
}

