#!/usr/bin/perl -w

use strict;
use utf8;
use warnings;

use DB_File;
use Errno;
use Event;
use Exception::Class
  'X::ProcessPacket' => {
    description =>
      'An error occuring during the processing of an syslog message.',
    fields => 'packet'
  },
  'X::ProcessPacket::Status' => {
    isa         => 'X::ProcessPacket',
    description => 'Got a packet with an unexpected status code.',
    fields      => [qw(packet status)],
  },
  ;
use FindBin ();
use Getopt::Long qw(GetOptions);
use IO::Socket::INET;
use POSIX qw(setsid);
use Proc::PID::File ();
use Regexp::Common qw(net);
use Sys::Syslog qw(closelog openlog syslog);

use constant RE_SYSLOG_DATE    => qr/\w\w\w [ 123]\d \d\d:\d\d:\d\d/;
use constant CRE_SYSLOG_PACKET => qr/
    ^
    \s*<\d{1,3}>
    ${\RE_SYSLOG_DATE}\s+\S+\s+perdition\.\w+\[\d{1,5}\]:
    \s+Auth:\ ($RE{net}{IPv4}):\d{1,5}->$RE{net}{IPv4}:\d{1,5}
    \s+client-secure=\S+
    \s+authorisation_id=\S+
    \s+authentication_id="[^"]+"
    \s+server="$RE{net}{domain}{-nospace}:[^"]+"
    \s+protocol=\S+
    \s+server-secure=\S+
    \s+status="([^"]+)"
    \s*$
  /ox;

### Auswertung der Kommandozeile ##############################################

our @argv = @ARGV;
GetOptions(
    'daemon!'   => \( our $Daemon = 1 ),
    'db-file=s' => \( our $DbFile = '/var/lib/noris-dracd.db' ),
    'debug+'    => \( our $Debug  = 0 ),
    'help|?'    => sub {
        require Config and Config->import;
        delete $ENV{ENV};
        our %Config;
        $Config{bin} =~ /^(.*)/;
        local $ENV{PATH} = $1;
        $0 =~ /^(.*)/;
        exec perldoc => -F => $1 or die "exec('perldoc -F $0'): $!\n";
    },
    'lifetime=i'   => \( our $Lifetime    = 600 ),
    'log-facility' => \( our $LogFacility = 'local0' ),
    'port=i'       => \( our $Port        = 1337 ),
) or exit 1;

### Debugging-Routinen ########################################################

{

    $Event::DebugLevel = $Debug;

    sub debug($$) {
        my ( $level, $message ) = @_;
        return if $Debug < $level;
        defined( $message = $message->() ) or return if ref $message;
        chomp $message;
        if ($Daemon) {
            my $priority = (qw(crit warning notice info))[ $level + 2 ];
            $priority = 'debug' unless defined $priority;
            syslog( $priority => $message );
        }
        else {
            print { $level < 0 ? \*STDERR : \*STDOUT } "$message\n";
        }
    }

    $SIG{USR1} = sub {
        $Event::DebugLevel = ++$Debug;
        debug( 1, "Incremented debuglevel to $Debug." );
    };

    $SIG{USR2} = sub {
        debug( 1, "Decrementing debuglevel to $Debug." );
        $Event::DebugLevel = --$Debug;
    };

    $SIG{__DIE__} = sub { debug( -2, "DIED: @_" ); exit $? };
    $SIG{__WARN__} = sub { debug( -1, "WARNING: @_" ) };
}

### Initialisierung ###########################################################

my $socket = IO::Socket::INET->new(
    Proto => 'udp',
    ( $Port =~ /:/ ? 'LocalAddr' : 'LocalPort' ) => $Port
) or die "Cannot open UDP socket on port $Port: $!\n";

if ($Daemon) {

    # Wir verwenden nicht Proc::Daemon,
    # weil das auch das UDP-Socket schließen würde.
    setsid();

    close STDIN;
    close STDOUT;
    close STDERR;
    fork and exit;

    die "Already running.\n"
      if Proc::PID::File->running( $Debug > 0 ? ( debug => 1 ) : (),
        verify => 1 );

    no warnings 'once';
    openlog( $FindBin::Script, 'pid', $LogFacility );
    debug( 0, 'Started' . ( @argv ? "; arguments: @argv" : '.' ) );
}

our $Db = tie our %Db, DB_File => $DbFile
  or die qq(Cannot tie database file "$DbFile": $!\n);

### Event-Loop ################################################################

{

    # Expiren von Alt-Einträgen:
    while ( my ( $ip, $time ) = each %Db ) {
        setup_expire_watcher_for_ip( $ip, $time + $Lifetime );
    }
    debug( 2 => \&state );

    my $syslog_watcher = Event->io(
        fd   => $socket,
        poll => 'r',
        cb   => sub {

            debug( 1 => 'Got UDP packet.' );

            if ( defined( $socket->recv( my $packet, 1 << 16 ) ) ) {

                eval {
                    local $SIG{__DIE__};
                    process_packet($packet);
                };

                if ($@)
                {    # Workaround, um Warnung durch ->caught() zu vermeiden,
                        # wenn es keine Exception gab.

                    if ( my $exception =
                        Exception::Class->caught('X::ProcessPacket') )
                    {
                        warn "Error processing packet: $exception\n";
                    }
                    elsif ( $exception = Exception::Class->caught ) {
                        if   ( ref $exception ) { $exception->rethrow }
                        else                    { die $exception }
                    }
                }
            }
            elsif ( !$!{EINTR} ) {
                warn "Unknown error receiving UDP packets: $!\n";
            }

            debug( 1 => 'Finished processing of UDP packet.' );
        },
    );

    my %sig_watcher = map {
        my $signal = $_;
        $signal => Event->signal(
            signal => $_,
            cb     => sub {
                debug( 0, "Got $signal signal." );
                Event::unloop_all();
            }
          )
    } qw(QUIT TERM);

    local $Event::DIED = sub {
        Event::verbose_exception_handler(@_);
        Event::unloop_all();
    };

    debug( 1 => 'Entering event loop.' );
    Event::loop();
    debug( 1 => 'Event loop stopped.' );
}

undef $Db;
untie %Db;

debug( 0, 'Terminating.' );
closelog() if $Daemon;
exit;

### Sub-Routinen ##############################################################

sub process_packet {
    my ($packet) = @_;

    my ( $client_ip, $status ) = $packet =~ CRE_SYSLOG_PACKET
      or X::ProcessPacket->throw(
        message => 'Unknown message format',
        packet  => $packet
      );

    X::ProcessPacket::Status->throw(
        message => 'Unexpected status',
        packet  => $packet,
        status  => $status
    ) if $status ne 'ok';

    register_ip($client_ip);
}

{
    my %expire_watcher;

    sub register_ip {
        my ($ip) = @_;

        $Db->put( $ip, my $time = time );
        sync_db();
        debug(  1 => "Registered IP address $ip at "
              . localtime( $Db{$ip} )
              . '.' );

        setup_expire_watcher_for_ip( $ip, $time + $Lifetime );

        debug( 2 => \&state );
    }

    sub setup_expire_watcher_for_ip {
        my ( $ip, $at ) = @_;

        if ( exists $expire_watcher{$ip} ) {
            ( delete $expire_watcher{$ip} )->cancel;
            debug( 1 => "Cancelled old expire watcher for IP address $ip." );
        }

        $expire_watcher{$ip} = Event->timer(
            at => $at,
            cb => sub {

                if ( $Db->del($ip) == 0 ) {
                    sync_db();
                    debug( 1 => "Expired IP address $ip." );
                }
                else {
                    debug( 0 => "IP address $ip not found!?" );
                }

                ( delete $expire_watcher{$ip} )->cancel;
                debug( 2 => "Cancelled expire watcher for IP address $ip." );

                debug( 2 => \&state );
            },
        );
        debug( 2 =>
              "Setup new expire watcher for IP address $ip (after $Lifetime s)."
        );
    }

    sub state {
        require Data::Dump and Data::Dump->import('pp')
          unless defined &pp;

        'Expire watchers active for: '
          . join( ' ', keys %expire_watcher )
          . "\nCurrent database: "
          . pp( \%Db ) . "\n";
    }
}

sub sync_db {
    my $error = $Db->sync or return;
    warn "Error #$error sync()ing database.\n";
}

### Exception-Handling ########################################################

{

    package X::ProcessPacket;

    sub full_message {
        my ($exception) = @_;
        $exception->message . ': ' . $exception->packet;
    }
}

__END__

=encoding utf8

=head1 NAME

noris-dracd - temporäre Freigabe von IP-Adressen

=head1 SYNOPSE

    noris-dracd -port 1337 \
                -lifetime 600 \
                -db-file /var/lib/noris-dracd.db

=head1 BESCHREIBUNG

Das Programm erwartet via syslog (UDP) Meldungen über erfolgreiche
Authorisierungen (auf dem Postfachserver) für jeweils eine bestimmte
Client-IP-Adresse in folgendem Format:

 <21>Apr 22 13:28:59 imapproxy1 perdition[25440]: Auth: 10.1.0.5->10.1.1.5 user="fany" server="imap1.noris.net" port="110" status="ok"

(Wobei Facility und Priority egal sind.)

Es vermerkt dann die fragliche Client-IP-Adresse in einer
BerkeleyDB-Hash-Datei.

IP-Adressen, für die seit eine konfigurierbaren Zeitspanne keine Meldungen mehr
eingetroffen sind, werden aus dieser Hash-Datei automatisch wieder entfernt.

=head1 OPTIONEN

=over 4

=item -port Port

zur Festlegung des UDP-Ports, auf dem die syslog-Meldungen erwartet werden;
Default: 1337

Es kann auch eine I<HostC<:>Port>-Kombination angegeben werden, damit nur
eine bestimmte Schnittstelle verwendet wird.

=item -db-file Hash-Datei

zur Festlegung der zu verwendenden Hash-Datei;
Default: C</var/lib/noris-dracd.db>

item -debug

zum Aktivieren von Debugging-Informationen.
Bei mehrfacher Verwendung der Option werden mehr entsprechende Informationen
ausgegeben.
Die Ausgabe erfolgt bei der Verwendung als Daemon über syslog, ansonsten auf
die Standardausgabe.

=item -log-facilty Facility

Facility fürs Loggen über syslog bei der Verwendung als Daemon;
Default: C<local0>

=item -nodaemon

damit der Prozess sich nicht in den Hintergrund verabschiedet

=item -help

=item -?

um (nur) diese Dokumentation anzeigen zu lassen.

=back

=head1 BEKANNTE PROBLEME

=over 4

=item *

Das Programm kümmert sich nicht um Locking der verwendeten
L<Datenbankdatei|/-db-file Hash-Datei>.
Um das sinnvoll tun zu können, müsste aber freilich sowieso erstmal geklärt
werden, ob und ggf. wie exim beim Lesezugriff damit umgeht.
Im strace fanden sich darauf keine eindeutigen Hinweise, z. B.:

 stat64("/etc/exim4/virtual_user.db", {st_mode=S_IFREG|0644, st_size=1277952, ...}) = 0
 open("/etc/exim4/virtual_user.db", O_RDONLY|O_LARGEFILE) = 3
 fcntl64(3, F_SETFD, FD_CLOEXEC)         = 0
 read(3, ""..., 512) = 512
 close(3)                                = 0
 stat64("DB_CONFIG", 0xbf7ebc4c)         = -1 ENOENT (No such file or directory)
 open("DB_CONFIG", O_RDONLY|O_LARGEFILE) = -1 ENOENT (No such file or directory)
 stat64("/var/tmp", {st_mode=S_IFDIR|S_ISVTX|0777, st_size=4096, ...}) = 0
 gettimeofday({1240492257, 516335}, NULL) = 0
 stat64("__db.002", 0xbf7ebd0c)          = -1 ENOENT (No such file or directory)
 open("/etc/exim4/virtual_user.db", O_RDONLY|O_LARGEFILE) = 3
 fcntl64(3, F_SETFD, FD_CLOEXEC)         = 0
 fstat64(3, {st_mode=S_IFREG|0644, st_size=1277952, ...}) = 0
 pread64(3, ""..., 4096, 0) = 4096
 stat64("/etc/exim4/virtual_user.db", {st_mode=S_IFREG|0644, st_size=1277952, ...}) = 0
 pread64(3, ""..., 4096, 262144) = 4096
 pread64(3, ""..., 4096, 24576) = 4096
 open("/etc/mtab", O_RDONLY)             = 4
 fstat64(4, {st_mode=S_IFREG|0644, st_size=466, ...}) = 0
 mmap2(NULL, 4096, PROT_READ|PROT_WRITE, MAP_PRIVATE|MAP_ANONYMOUS, -1, 0) = 0xb7f01000
 read(4, ""..., 4096) = 466
 close(4)                                = 0
 munmap(0xb7f01000, 4096)                = 0
 open("/proc/stat", O_RDONLY)            = 4
 fstat64(4, {st_mode=S_IFREG|0444, st_size=0, ...}) = 0
 mmap2(NULL, 4096, PROT_READ|PROT_WRITE, MAP_PRIVATE|MAP_ANONYMOUS, -1, 0) = 0xb7f01000
 read(4, ""..., 1024) = 1024
 read(4, ""..., 1024) = 210
 read(4, "", 1024)                       = 0
 close(4)                                = 0

=back

