#!/usr/bin/perl -w

# $Id: check_maildelay,v 1.11 2004/09/01 12:10:39 fany Exp $

=pod

=head1 NAME

check_maildelay

=head1 BESCHREIBUNG

Netsaint-kompatibles Script zum Monitoring der Mail-Zustellung

=head1 AUFRUFSYNTAX

    check_maildelay [OPTIONEN] { <user> <password> }+

Das Script fragt alle angegebenen Postfcher via POP3 ab, ermittelt jeweils die
neueste Nachricht (vgl. unten) und schlgt Alarm, falls gar keine gefunden
wurde, falls die neueste lter ist als die angegebene(n) Schwelle(n) oder sonst
ein Fehler auftritt.

=head1 OPTIONEN

=over 4

=item -pop3-server Server

POP3-Server, der abgefragt werden soll

=item -pop3-timeout Sekunden

Timeout, der an L<Net::POP3|Net::POP3> bergeben wird

=item -warning-age Sekunden

Maximal-Alter, das die neueste Nachricht pro Postfach haben darf, bevor eine
Warnung erzeugt wird

=item -critical-age Sekunden

Maximal-Alter, das die neueste Nachricht pro Postfach haben darf, bevor ein
kritischer Alarm ausgelst wird

=item -warning-oldest Sekunden

Maximal-Alter, das die lteste E-Mail pro Postfach haben darf, bevor eine
Warnung erzeugt wird

=item -critical-oldest Sekunden

Maximal-Alter, das die lteste E-Mail pro Postfach haben darf, bevor ein
kritischer Alarm erzeugt wird

=item -warning-delivery-time Sekunden

Dauerte die Zustellung einer im Postfach gefundenen E-Mail lnger als die hier
angegebene Zeitspanne, wird einer Warnung erzeugt.

=item -critical-delivery-time Sekunden

Dauerte die Zustellung einer im Postfach gefundenen E-Mail lnger als die hier
angegebene Zeitspanne, wird ein kritischer Alarm erzeugt.

=item -first-client FQDN

Normalerweise wird die Zustellzeit vom ersten bis zum letzten Received:-Header
gemessen.
Alternativ kann hier der FQDN des MTAs angegeben werden, von dessen (erster)
Auslieferung der Mail an gemessen werden soll.
Wird auch ein L<-first-server|/-first-server FQDN> angegeben, mssen beide
FQDNs stimmen, d. h. es wird dann nach einer Zustellung der Mail vom
L<-first-client|/-first-client FQDN> an den
L<-first-server|/-first-server FQDN> gesucht.
Wird keine solche gefunden, wird ein UNKNOWN-Zustand erzeugt.
Die Option kann auch mehrfach verwendet werden; es wird dann nach dem ersten
Auftreten eines der angegebenen FQDNs gesucht.

=item -first-server FQDN

Siehe L<-first-client|/-first-client FQDN>.

=item -last-client FQDN

Siehe L<-first-client|/-first-client FQDN>, jedoch wird bei mehreren
Treffern der (zeitlich) letzte gewertet.

=item -last-server FQDN

Siehe L<-first-client|/-first-client FQDN>, jedoch wird bei mehreren
Treffern der (zeitlich) letzte gewertet.

=item -forward-mails-to E-Mail-Adresse

Die Header aller Mails, die Alarme erzeugten, werden (einzeln) an die angegebene
E-Mailadresse weitergeleitet(, um dort z. B. genauer analysiert zu werden).
Es knnen mehrere Zieladressen angegeben werden, indem die Option entsprechend
oft mit jeweils einem Argument verwendet wird.

=item -rrd RRD

Dateiname einer Round Robin Database (RRD), in die die Zustellzeit (in Sekunden)
aller gefundenen E-Mails gespeichert werden soll.
Dabei erfolgt der Eintrag unter dem Zeitpunkt des ersten bzw. mit
L<-first-client|/-first-client FQDN> und/oder
L<-first-server|/-first-server FQDN> ausgewhlten C<Received:>-Headers.

=item -ds DS

Name der RRD-Data-Source, unter der (fr die Option L<-rrd|/-rrd RRD>) die
Zustellzeiten gespeichert werden sollen.
Per Default wird der Username des jeweils abgefragten Postfachs verwendet.

=item -delete

Bei Angabe dieses Switches werden nach dem Abfragen automatisch alle Nachrichten
mit Ausnahme der jeweils neuesten aus jedem Postfach entfernt.

=item -debug

Schaltet lustige Debugging-Meldungen auf STDERR ein, z. B. wird angezeigt,
von welchem bis zu welchem Received:-Header gemessen wurde etc.

=item -help

=item -?

gibt nur diese Dokumentation aus.

=back

=head1 AUTOR

 Martin H. Sluka <fany@noris.net>
 fr die noris network AG
 im Rahmen von RT#114370

=cut

use 5.006;
use strict;
use warnings;

use Date::Parse qw(str2time);
use FindBin ();
use Getopt::Long qw(GetOptions);
use Mail::Header ();
use Net::POP3;

use lib do { $FindBin::Bin =~ /^(.*)/; $1 };

sub filter($\@@) {
    my $key = shift;
    my %value;
    @value{ map lc, @{ +shift } } = ();
    return @_ unless keys %value;
    grep exists $value{ lc $_->{$key} }, @_;
}

GetOptions(
    'critical-age|critical-threshold=i' => \( my $Critical_Age ),
    'critical-delivery-time=i'          => \( my $Critical_Delivery ),
    'critical-oldest=i'                 => \( my $Critical_Oldest ),
    'debug+'                            => \my $Debug,
    'delete!'                           => \my $Delete,
    'ds=s'                              => \my $DS,
    'first-client=s'                    => \my @First_Client,
    'first-server=s'                    => \my @First_Server,
    'forward-mails-to=s'                => \my @Forward,
    'help|?' =>
      sub { exec perldoc => -F => $0 or die "exec('perldoc -F $0'): $!\n" },
    'last-client=s'  => \my @Last_Client,
    'last-server=s'  => \my @Last_Server,
    'pop3-server=s'  => \( my $POP3_Server = 'mail.noris.net' ),
    'pop3-timeout=i' => \( my $POP3_Timeout ),
    'rrd=s'          => \my $RRD,

    # Die "rrdtool" Option dient nur der Rueckwaerts-Kombatibilitaet.
    'rrdtool=s'                       => sub {},
    'warning-age|warning-threshold=i' => \( my $Warning_Age ),
    'warning-delivery-time=i' => \( my $Warning_Delivery ),
    'warning-oldest=i'        => \( my $Warning_Oldest ),
) or exit 1;

{

    package my::noris::NetSaint;
    use base 'noris::NetSaint';

    sub _orlist($@) {
        my $prefix = shift;
        return '' unless @_;
        " $prefix " . join ' or ', @_;
    }

    sub delivery_not_found {
        my ( $self, $prefix, $clients, $servers, $header ) = @_;
        $self->xupdate(
            Unknown => "$prefix: No delivery"
              . _orlist( from => @$clients )
              . _orlist( to   => @$servers )
              . ' found',
            $header
        );
    }

    # Diese Methode soll in den Fllen aufgerufen werden, in denen eine Mail an
    # die bei -forward-mails-to angegebenen E-Mail-Adresse(n) geschickt werden
    # soll. Sie fungiert als Ersatz bzw. Wrapper fr noris::NetSaint's Methode
    # ->update. Als zustzliches, letztes Argument erwartet sie den Text fr
    # den Body der E-Mail.
    sub xupdate {
        my $self   = shift;
        my $header = pop;
        my ( $status, @message ) = @_;
        if (@Forward) {
            unless ( defined( my $pid = open my $sendmail, '|-' ) ) { }
            elsif ($pid) {
                print $sendmail "Subject: $status: @message\n\n$header";
                close $sendmail;
            }
            else {
                exec '/usr/sbin/sendmail', -oi => @Forward
                  or die "exec returned $?: $!";
            }
        }
        $self->update(@_);
    }
}

our $NetSaint = new my::noris::NetSaint;

die "USAGE: $0 { <user> <password> }+\n" unless @ARGV && not @ARGV & 1;

while (@ARGV) {
    my ( $user, $password ) = splice @ARGV, 0, 2;
    $POP3_Timeout = $ENV{DEFAULT_SOCKET_TIMEOUT} - time + $^T - 2
      if !$POP3_Timeout && defined $ENV{DEFAULT_SOCKET_TIMEOUT};
    no warnings 'uninitialized';    # sonst gibt's Warnungen von Net::POP3
    my $pop = new Net::POP3 $POP3_Server,
      defined $POP3_Timeout ? ( Timeout => $POP3_Timeout ) : ();
    unless ($pop) {
        $NetSaint->update( Critical => "Cannot connect to $POP3_Server: $!" );
    }
    elsif ( !defined( my $messages = $pop->login( $user, $password ) ) ) {
        $NetSaint->update(
            Unknown => sprintf 'Cannot login as "%s": %s',
            $user, $pop->message
        );
    }
    elsif ( !$messages ) {
        $NetSaint->update( Unknown => "No messages found in mailbox $user." );
    }
    elsif ( not my $msgs = $pop->list ) {
        $NetSaint->update(
            Unknown => "Cannot get list of messages for mailbox $user: "
              . $pop->message );
    }
    else {
        my (
            $latest_arrival, $latest_header, $latest_msg,
            $oldest_arrival, $oldest_header, %rrd_update
        );
      MESSAGE: for ( sort { $a <=> $b } keys %$msgs ) {
            unless ( my $header = $pop->top($_) ) {
                $NetSaint->update( Unknown =>
"Error retrieving header for message #$_ from mailbox $user: "
                      . $pop->message );
            }
            else {
                my $head = Mail::Header->new($header) or die;
                $header = join '', @$header;
                $head->unfold('Received');
                my @received;
                for ( $head->get('Received') ) {
                    /^from\s+(\S+).*\s+by\s+(\S+).*;\s+([^;]+?)(?: \/ .*)?\s*$/i
                      or next;
                    unless ( my $time = str2time $3 ) {
                        $NetSaint->xupdate(
                            Unknown => "Could not parse date: $3",
                            $header
                        );
                        next MESSAGE;
                    }
                    else {
                        push @received,
                          {
                            client => lc $1,
                            server => lc $2,
                            time   => $time,
                            n      => scalar @received
                          };
                    }
                }
                unless (@received) {
                    $NetSaint->xupdate(
                        Unknown =>
"Could not find Received: headers in message #$_ from mailbox $user",
                        $header
                    );
                    next MESSAGE;
                }
                if ( !defined $latest_arrival
                    || $latest_arrival < $received[-1]{time} )
                {
                    $latest_arrival = $received[-1]{time};
                    $latest_header  = $header;
                    $latest_msg     = $_;
                }
                if ( !defined $oldest_arrival
                    || $oldest_arrival > $received[-1]{time} )
                {
                    $oldest_arrival = $received[-1]{time};
                    $oldest_header  = $header;
                }
                if (   $Critical_Delivery
                    || $Warning_Delivery
                    || defined $RRD )
                {
                    unless (
                        my ($first) = filter
                        server => @First_Server,
                        filter
                        client => @First_Client,
                        reverse @received
                      )
                    {
                        $NetSaint->delivery_not_found(
                            "Message #$_ from mailbox $user",
                            \@First_Client, \@First_Server, $header );
                    }
                    elsif (
                        not my ($last) = filter
                        server => @Last_Server,
                        filter
                        client => @Last_Client,
                        @received
                      )
                    {
                        $NetSaint->delivery_not_found(
                            "Message #$_ from mailbox $user",
                            \@Last_Client, \@Last_Server, $header );
                    }
                    elsif ( $first->{n} < $last->{n} ) {
                        $NetSaint->xupdate(
                            Unknown =>
"Message #$_ from mailbox $user: (last) delivery from $last->{client} to $last->{server} occured before (first) delivery from $first->{client} to $first->{server}",
                            $header
                        );
                    }
                    elsif ( $first->{n} == $last->{n} ) {
                        $NetSaint->xupdate(
                            Unknown =>
"Message #$_ from mailbox $user: selected the same delivery from $first->{client} to $first->{server} twice",
                            $header
                        );
                    }
                    else {
                        my $delivery_time = $last->{time} - $first->{time};
                        print STDERR
"Measuring from #$first->{n} ($first->{client} -> $first->{server}) to #$last->{n} ($last->{client} -> $last->{server}): $delivery_time s\n"
                          if $Debug;
                        if (   $Critical_Delivery
                            && $delivery_time > $Critical_Delivery )
                        {
                            $NetSaint->xupdate(
                                Critical =>
"Delivery of message #$_ from mailbox $user took $delivery_time seconds",
                                $header
                            );
                        }
                        elsif ($Warning_Delivery
                            && $delivery_time > $Warning_Delivery )
                        {
                            $NetSaint->xupdate(
                                Warning =>
"Delivery of message #$_ from mailbox $user took $delivery_time seconds",
                                $header
                            );
                        }
                        else {
                            $NetSaint->update( OK =>
"Delivery of message #$_ from mailbox $user took $delivery_time seconds"
                            );
                        }
                        $rrd_update{ $first->{time} } = $delivery_time
                          unless !defined $RRD
                              || exists $rrd_update{ $first->{time} }
                              && $rrd_update{ $first->{time} } < $delivery_time;
                    }
                }
            }
        } # for ( sort { $a <=> $b } keys %$msgs )

 	if (keys %rrd_update)
        {
            require RRDs;

            my $ds = defined $DS ? $DS : 'value';

            if (!-e $RRD)
            {
                RRDs::create ($RRD, '--step', '300',
                        "DS:${ds}:GAUGE:600:0:10800",
                        "RRA:MIN:0.1:1:12096",
                        "RRA:AVERAGE:0.1:1:12096",
                        "RRA:MAX:0.1:1:12096",
                        "RRA:MIN:0.1:12:8880",
                        "RRA:AVERAGE:0.1:12:8880",
                        "RRA:MAX:0.1:12:8880");
                if (my $errmsg = RRDs::error ())
                {
                    die ("RRDs::create: $errmsg");
                }
            }

            if (-e $RRD)
            {
                my @cmd = ($RRD, '-t', $ds);
                for (sort (keys %rrd_update))
                {
                    push (@cmd, $_ . ':' . $rrd_update{$_});
                }
                RRDs::update (@cmd);
                if (my $errmsg = RRDs::error ())
                {
		    if ($errmsg =~ m/illegal attempt to update using time \d+ when last update time is \d+/i)
                    {
                        # this error is ignored.
                        warn ("RRDs::update: $errmsg") if ($Debug);
                    }
                    else
                    {
                        die ("RRDs::update: $errmsg");
                    }
                }
            }
        } # if (keys %rrd_update)
 
        unless ( defined $latest_arrival ) {
            $NetSaint->update(
                Unknown => "No datestamps from mailbox $user at all." );
        }
        else {
            my $oldest_age = $^T - $oldest_arrival;
            if ( defined $Critical_Oldest || defined $Warning_Oldest ) {

	        # Wir mssen hier ->xupdate (und nicht ->add_message und dann
		# ->atleast) verwenden, weil das evtl. die $message fr die
		# Funktionalitt -forward-mails-to braucht:
                my $message =
                  sprintf 'Oldest message in mailbox %s is %.0f minutes old.',
                  $user, $oldest_age / 60;
                if ( $Critical_Oldest && $oldest_age > $Critical_Oldest ) {
                    $NetSaint->xupdate( Critical => $message, $oldest_header );
                }
                elsif ( $Warning_Oldest && $oldest_age > $Warning_Oldest ) {
                    $NetSaint->xupdate( Warning => $message, $oldest_header );
                }
                else {
                    $NetSaint->update( OK => $message );
                }
            }
            if ( defined $Critical_Age || defined $Warning_Age ) {
                my $latest_age = $^T - $latest_arrival;

                # Wir mssen hier ->xupdate (und nicht ->add_message und dann
                # ->atleast) verwenden, weil das evtl. die $message fr die
                # Funktionalitt -forward-mails-to braucht:
                my $message =
                  sprintf 'Newest message in mailbox %s is %.0f minutes old.',
                  $user, $latest_age / 60;
                if ( $Critical_Age && $latest_age > $Critical_Age ) {
                    $NetSaint->xupdate( Critical => $message, $latest_header );
                }
                elsif ( $Warning_Age && $latest_age > $Warning_Age ) {
                    $NetSaint->xupdate( Warning => $message, $latest_header );
                }
                else {
                    $NetSaint->update( OK => $message );
                }
            }
            $NetSaint->update(
                OK => sprintf
                  'Oldest message in mailbox %s is %.0f minutes old.',
                $user, $oldest_age / 60
            ) unless $NetSaint->message;

            if ($Delete) {
                $_ != $latest_msg and $pop->delete($_) for keys %$msgs;
            }
        }
    }
    $pop->quit if $pop;
}
