#!/usr/bin/perl -w

use strict;
use warnings;
use utf8;

use Errno;
use Fcntl qw(O_APPEND O_CREAT O_WRONLY);
use FindBin ();
use Getopt::Long qw(GetOptions);
use Net::DNS qw(mx);
use noris::NetSaint;
use Regexp::Common qw(net);
use Socket qw(inet_ntoa);

use constant {
    LABEL   => qr/[A-Za-z0-9][-A-Za-z0-9]{0,61}[A-Za-z0-9]/,
    TIMEOUT => "999 Timeout\n",
};

my ( %SmtpOption, %StatusMap );
GetOptions(
    'data-file=s'   => \my $Data_File,
    'from=s'        => \my $From,
    'host=s'        => \my @Hosts,
    'map-status=s%' => sub {
        ( undef, my $smtp_status, my $netsaint_status ) = @_;
        my $smtp_command = $smtp_status =~ s/^(.*?)\s*(\d{1,3})\z/$2/ && $1;
        die "Unknown SMTP status code: $smtp_status\n"
          if length $smtp_status && $smtp_status !~ /^\d{1,3}\z/;
        $StatusMap{$smtp_command}{$smtp_status} =
          noris::NetSaint::Status->new($netsaint_status);
    },
    'smtp-option=s' => \%SmtpOption,
    'timeout=i'     => sub { $SmtpOption{Timeout} = $_[1] },
    'to=s'          => \my @To,
    'help|?!' =>
      sub { exec perldoc => -F => $0 or die "exec('perldoc -F $0'): $!\n" },
) or exit 1;

sub map_status4method {
    my ( $method, $code ) = @_;
    while ( length $code ) {
        return $StatusMap{$method}{$code} if defined $StatusMap{$method}{$code};
        return $StatusMap{''}{$code}      if defined $StatusMap{''}{$code};
        $code =~ s/.\z//;
    }
}

die "At least one recipient must be specified.\n" unless @To;
unless ( defined $From ) {
    my $host = `hostname -f` or die "Cannot detect hostname.\n";
    chomp $host;
    my $user = $ENV{USER} || getpwuid $<
      or die "Cannot detect user from ENVironment.\n";
    $From = "$user\@$host";
}

my $NetSaint = noris::NetSaint->new;

my $hosts_given = @Hosts;

unless (@Hosts) {
    require Mail::Address;
    my $resolver = Net::DNS::Resolver->new;
    for (@To) {
        my @hosts;
        if (
            (
                my $number_of_addresses = my ($address) =
                Mail::Address->parse($_)
            ) != 1
          )
        {
            die
qq(Parsing "$_" resulted in $number_of_addresses e-mail addresses (instead of one).);
        }
        elsif ( my @mx = mx( $resolver, $address->host ) ) {
            @hosts = map lc $_->exchange, sort {
                     $a->preference <=> $b->preference
                  || $a->exchange cmp $b->exchange
            } @mx;
        }
        elsif ( $resolver->errorstring =~ /^N(XDOMAIN|OERROR)\z/ ) {

            # NOERROR z. B. bei nur CNAMEs
            @hosts = lc $address->host;    # Fallback auf A-Record
        }
        else {
            die "Could not resolve DNS settings for $_: "
              . $resolver->errorstring . "\n";
        }
        unless (@Hosts) { @Hosts = @hosts }
        elsif ( "@Hosts" ne "@hosts" ) {
            die "Different MX sets: (@Hosts) vs. (@hosts).\n";
        }
    }
}

{
    my %ips4fqdn;

    sub resolve_host($) {
        my ($fqdn) = @_;
        unless ( exists $ips4fqdn{$fqdn} ) {
            ( undef, undef, undef, undef, my @ips ) = gethostbyname($fqdn);
            @{ $ips4fqdn{$fqdn} } = map inet_ntoa($_)
              || die("Cannot convert IP.\n"), @ips;
        }
        return @{ $ips4fqdn{$fqdn} };
    }
}

my %connect2ip_port;
for my $hostport (@Hosts) {
    my $host = $hostport;
    my $port = $host =~ s#(:[\w\(\)/]+)$## && $1;

  # Regulärer Ausdruck ist dem aus IO::Socket::INET::_sock_info() nachempfunden.

    if ( $host =~ /^$RE{net}{IPv4}\z/ ) {
        $connect2ip_port{$hostport} = undef
          unless exists $connect2ip_port{$hostport};
    }
    else {
        defined $connect2ip_port{ $_ . $host }
          or $connect2ip_port{ $_ . $port } = $hostport
          for resolve_host($host);
    }
}

unless ( keys %connect2ip_port ) {
    $NetSaint->update( Critical => 'Keine zuständigen Hosts gefunden.' );
    exit;
}

{

    package my::Net::SMTP;

    use Net::Cmd qw(CMD_OK);
    use Net::Config;
    use Net::SMTP;    # NICHT "use base", weil sonst AUTOLOAD nicht greift

    # gepatchte Version, um auch bei direkter Ablehnung der Verbindung
    # an die Fehlermeldung zu gelangen, vgl. etwa RT#334134
    sub new {
        my $self = shift;
        my $type = ref($self) || $self;
        my ( $host, %arg );
        if ( @_ % 2 ) {
            $host = shift;
            %arg  = @_;
        }
        else {
            %arg  = @_;
            $host = delete $arg{Host};
        }
        my $hosts = defined $host ? $host : $NetConfig{smtp_hosts};
        my $obj;

        my $h;
        foreach $h ( @{ ref($hosts) ? $hosts : [$hosts] } ) {
            $obj = Net::SMTP->IO::Socket::INET::new(
                PeerAddr => ( $host = $h ),
                PeerPort => $arg{Port} || 'smtp(25)',
                LocalAddr => $arg{LocalAddr},
                LocalPort => $arg{LocalPort},
                Proto     => 'tcp',
                Timeout   => defined $arg{Timeout}
                ? $arg{Timeout}
                : 120
            ) and last;
        }

        return undef
          unless defined $obj;

        $obj->autoflush(1);
        $obj->debug( exists $arg{Debug} ? $arg{Debug} : undef );
        unless ( $obj->response == CMD_OK ) {
            if ( defined fileno $obj ) {
                my $code    = ${*$obj}{net_cmd_code};
                my @message = @{ ${*$obj}{net_cmd_resp} };
                $obj->close();
                $@ =
                  defined $code
                  ? "$code @message"
                  : 'unknown error at connection opening';
            }
            else { $@ = '000 Connection closed' }
            return undef;
        }

        ${*$obj}{'net_smtp_exact_addr'} = $arg{ExactAddresses};
        ${*$obj}{'net_smtp_host'}       = $host;

        ( ${*$obj}{'net_smtp_banner'} ) = $obj->message;
        ( ${*$obj}{'net_smtp_domain'} ) = $obj->message =~ /\A\s*(\S+)/;

        unless ( $obj->hello( $arg{Hello} || "" ) ) {
            if ( defined fileno $obj ) {
                my $code    = ${*$obj}{net_cmd_code};
                my @message = @{ ${*$obj}{net_cmd_resp} };
                $obj->close();
                $@ =
                  defined $code ? "$code @message" : 'unknown error after HELO';
            }
            else { $@ = '000 Connection closed after HELO' }
            return undef;
        }

        bless \$obj, $type;
    }

    {
        no warnings 'redefine';

        sub Net::Cmd::getline {
            my $cmd = shift;

            ${*$cmd}{'net_cmd_lines'} ||= [];

            return shift @{ ${*$cmd}{'net_cmd_lines'} }
              if scalar( @{ ${*$cmd}{'net_cmd_lines'} } );

            my $partial =
              defined( ${*$cmd}{'net_cmd_partial'} )
              ? ${*$cmd}{'net_cmd_partial'}
              : "";
            my $fd = fileno($cmd);

            return undef
              unless defined $fd;

            my $rin = "";
            vec( $rin, $fd, 1 ) = 1;

            my $buf;

            until ( scalar( @{ ${*$cmd}{'net_cmd_lines'} } ) ) {
                my $timeout = $cmd->timeout || undef;
                my $rout;
                if ( select( $rout = $rin, undef, undef, $timeout ) ) {
                    unless ( sysread( $cmd, $buf = "", 1024 ) ) {
                        carp(
                            ref($cmd) . ": Unexpected EOF on command channel" )
                          if $cmd->debug;
                        $cmd->close;
                        return undef;
                    }

                    substr( $buf, 0, 0 ) =
                      $partial;    ## prepend from last sysread

                    my @buf =
                      split( /\015?\012/, $buf, -1 );    ## break into lines

                    $partial = pop @buf;

                    push( @{ ${*$cmd}{'net_cmd_lines'} }, map { "$_\n" } @buf );

                }
                else { die ::TIMEOUT }
            }

            ${*$cmd}{'net_cmd_partial'} = $partial;

            shift @{ ${*$cmd}{'net_cmd_lines'} };
        }
    }

    sub AUTOLOAD {
        my $self = shift;
        our $AUTOLOAD =~ /([^:]+)$/ and my $method = $1;
        return if $method eq 'DESTROY';

        # Hack für kürzere Fehlermeldungen bei Ablehnung nach DATA,
        # vgl. RT#366924:
        ${*$$self}{net_cmd_resp} = [] if $method eq 'dataend';

        my ( $code, $success );
        eval {
            local $SIG{__DIE__};
            $success = $$self->$method(@_);
            $code = $$self->code;
        };
        $code = 999 if !defined $code && $@ eq ::TIMEOUT;
        unless ( defined $code ) {
            $NetSaint->update( Critical => "$@ during ->$method("
                  . join( ',', map qq("$_"), @_ )
                  . ')' );
        }
        elsif ( my $status = ::map_status4method( $method, $code )
            || !$success && 'Critical' )
        {
            $NetSaint->update( $status => "after calling ->$method("
                  . join( ',', map qq("$_"), @_ )
                  . "): $code "
                  . $$self->message );
        }
        $success;
    }
}

$SmtpOption{Timeout} = $ENV{DEFAULT_SOCKET_TIMEOUT} - time + $^T - 3
  if !defined $SmtpOption{Timeout} && defined $ENV{DEFAULT_SOCKET_TIMEOUT};

open my $data_fh, '<', $Data_File
  or die "open('<','$Data_File'): $!\n"
  if defined $Data_File;

sub runtime() {
    my $runtime = sprintf '%.f', time - $^T;
    "$runtime second" . ( $runtime != 1 && 's' );
}

Host:
while ( my ( $ip_port, $fqdn_port ) = each %connect2ip_port ) {
    my $host = ( defined $fqdn_port && "$fqdn_port " ) . "[$ip_port]";
    unless ( my $smtp = my::Net::SMTP->new( $ip_port, %SmtpOption ) ) {

        # Bei (m)einem Test kam im Timeout-Fall ein EINPROGRESS raus.
        # Ich habe aber nicht genauer nachvollzogen, ob das immer so ist
        # und lasse daher den regulären Ausdruck, der wiederum nicht für alle
        # Locales funktionieren wird, sicherheitshalber zusätzlich stehen,
        my $code = defined $@
          && (
              $@ =~ /^(\d\d\d) / ? $1
            : $@ =~ /\btimeout\b/i
            || $!{EINPROGRESS} ? 999
            : $! == $!{ECONNREFUSED} && 990
          );
        ( my $message = defined $@ && $@ ) =~ s/^000 //;

        $NetSaint->update(
            map_status4method( new => $code )
              || 'Critical' => ( $hosts_given != 1 && "$host: " )
              . (
                $@
                ? "at connection opening: $message"
                : 'unknown error at connection opening after ' . runtime()
              )
        );
    }
    else {
        $smtp->mail($From) or next Host;
        $smtp->to($_) or next Host for @To;
        if ($data_fh) {
            $smtp->data or next Host;
            $smtp->datasend($_) or next Host while <$data_fh>;
            close $data_fh;
            $smtp->dataend or next Host;
        }
        else {

            # mehrere Methodenaufrufe, damit's kürzere Fehlermeldungen gibt,
            # vgl. RT#366924-1:
            $smtp->data
              and $smtp->datasend(<<_) and $smtp->dataend or next Host;
Subject: Test-Mail
From: $From
To: ${\join ',', @To}
X-Mailer: $0

Nur ein Test. 
_
        }
        $smtp->quit or next Host;

        $NetSaint->status('OK');
        $NetSaint->add_message(
            'Injected message for ' . join( ', ', @To ) . " at $host." );
        exit;
    }
}

__END__

=head1 NAME

check_inject_email -- NetSaint-Plugin zur Einlieferung von E-Mails per SMTP

=head1 SYNOPSE

    check_inject_email -to noristechnik@aol.com  \
                       -map-status to451=Warning \
                       -map-status 000=Warning

=head1 NOTWENDIGE ARGUMENTE

=over 4

=item -to

Ziel-Adresse für die E-Mail.
Kann mehrfach angegeben werden, um die Mail an mehrere Adressen zu schicken.

=back

=head1 OPTIONEN

Alle Optionen erwarten jeweils ein Argument.

=over 4

=item -host

Gibt den Host an, auf dem die Mail eingeliefert werden soll; ein ggf. vom
Standard (25) abweichender TCP-Port kann durch einen Doppelpunkt getrennt
angehängt werden.
Es können auch mehrere Hosts angegeben werden; der Test gilt dann als OK, sobald
die E-Mail erfolgreich bei einem dieser Hosts eingeliefert werden konnte.
Werden keine Hosts angegeben, so werden sie aus den MX-Records der
Ziel-Domain(s) der angegebenen L</-to|Ziel-Adressen> ermittelt;
sofern keine MX-Records angegeben sind, wird der Hostname selbst verwendet.
Sollten dabei bei mehreren L</-to|Ziel-Adressen> unterschiedliche Hosts
ermittelt werden, bricht das Plugin mit einem unbekannt-Status ab.

=item -smtp-option Name=Wert

Optionen, die direkt an L<Net::SMTP> übergeben werden, z. B.

    -smtp-option Timeout=4
    -smtp-option LocalAddr=1.2.3.4

Wird hiermit kein I<Timeout> gesetzt, ist aber die Environment-Variable
DEFAULT_SOCKET_TIMEOUT gesetzt, wird automagisch ein sinnvoller Wert bestimmt.

=item -from

Absender-Adresse für "MAIL FROM"; wird keine angegeben, wird sie aus dem
User- und Hostnamen zusammengesetzt, der das Plugin aufgerufen hat.

=item -data-file

Name einer Datei, die den Inhalt der zu versendenden Mail (inkl. Header)
enthält.
Wird keine angegeben, wird ein Default-Inhalt verwendet, der im Quelltext
nachgelesen werden kann.

=item -map-status SMTP-Status=Nagios-Status

Normalerweise lösen sämtliche Fehler bei der SMTP-Kommunikation einen kritischen
Fehler aus.
Bei Bedarf kann hier jedoch für bestimmte SMTP-Status-Codes ein anderer
Nagios-Status eingestellt werden.
Wird dem SMTP-Status der Name einer L<Net::SMTP>-Methode vorangestellt, so gilt
die Festlegung nur für durch diese Methode ausgelöste SMTP-Statusse.
Als Spezialfälle stehen Status 000 für Verbindungsabbrüche - dies ist bislang
aber nur für die C<new>-Methode implementiert -, 990 für aktive Ablehnung von
Verbindungen (Connection refused) und 999 für Timeouts zur Verfügung.

Alle Status-Codes können auch abgekürzt werden, d. h. C<5> gilt z. B. für alle
"harten" Fehler und C<55> eben für alle mit diesen Ziffern beginnenden Status-
Codes (jeweils als Fallback, falls auch für den speziellen Status-Code eine
Regel angegeben ist).

Beispiele:

=over 4

=item *

Ein SMTP-Status 421 nach einem "RCPT TO"-Befehl soll nur eine Warnung auslösen:

    -map-status to421=Warning

=item *

Ein SMTP-Status 550 soll generell zu einem Unknown-Status führen:

    -map-status 550=Unknown

=item *

Verbindungsabbrüche unmittelbar nach dem Verbindungsaufbau sollen nur eine
Warnung auslösen:

    -map-status new000=Warning

=item *

Timeouts und Verbindungsablehnungen sollen nur eine Warnung auslösen:

    -map-status new9=Warning

=back

B<Wichtig:> Hier eingestellte Statusse greifen nur, wenn die Zustellung an alle
Hosts fehlschlägt.
Andernfalls ist der Status immer C<OK>.

=item -help

=item -?

Zeigt nur diese Dokumentation an.

=back

=head1 AUTOR

 Martin H. Sluka <fany@noris.net>
 für die noris network AG

=head1 IDEEN

Evtl. wäre es doch besser, einfach alle IP-Adressen als Array-Referenz an
L<Net::SMTP>-E<gt>new zu übergeben und somit im Ergebnis nur noch für den
letzten Host, bei dem eine Einlieferung versucht wird, eine Meldung zu erzeugen.
Der Autor hat dazu aber noch keine klare Meinung und lässt's daher vorerst.

=cut

