=head1 Radius-Accounting

... funktioniert grundsätzlich so:

Da (wegen UDP und der Tatsache, dass wir mehrere Radius-Server haben) in den
Radius-Accounting-Logs letztlich keine Reihenfolge der Datensätze garantiert
werden kann, haben wir's stateless implementiert.
D. h., wir betrachten ausschließlich die Datensätze mit
C<Acct-Status-Type: Stop>.
Um Doppel-Accounting (aufgrund doppelt geloggter Datensätze, was wegen der
Verwendung von UDP passieren kann und faktisch auch passiert) zu vermeiden,
merken wir uns alle bereits gesehenen Datensätze (abzüglich der in der
Konstante C<REMOVE_FIELDS_RE> definierten Felder) in einer mit Cache-Datei,
aus der alte Einträge (vgl. Konstante C<KEEP_IN_CACHE>) vor dem eigentlichen
Accounting-Lauf automatisch entfernt werden.

Pro Datensatz aus der Log-Datei werden zwei Accounting-Datensätze geschrieben:

=over 4

=item 1.

einer mit Dienst C<ip-$subdienst> für die übertragenen Pakete und Bytes

=item 2.

einer mit Dienst C<zeit-$subdienst> für die Verbindungszeit.
Diese wird in die Spalte C<bytes> eingetragen,
C<pakete> wird hier konstant auf C<1> gesetzt.

=back

Der Subdienst wird anhand verschiedener Kriterien (vgl. Quelltext) ermittelt.
Derzeit gibt es C<dialin> (via QSC), C<ipass>, C<sdsl>, C<tdsl> und C<wlan>.

=cut

use utf8;
use strict;
use warnings;
use Cf
  qw($CACHEDIR $NAS_IP_ADDRESSES $NAS_IP_ADDRESSES_IGNORE $WDESCR);
use DB_File;
use POSIX qw(ceil);

use Dbase::Globals qw(bignum find_descr find_dienst get_person);
use Dbase::Help qw(Do DoFn qquote DoTime);
use Fehler qw(fehler);

use constant DIRECTIONS => qw(Input Output);

# Felder, die pro Datensatz genau einmal vorkommen müssen:
use constant REQUIRED_FIELDS => qw(Acct-Status-Type Timestamp User-Name);

# Felder, die pro Datensatz maximal einmal vorkommen dürfen:
use constant OPTIONAL_FIELDS => qw(Acct-Delay-Time Called-Station-Id);

# User, bei denen keine Warnungen ausgegeben werden sollen,
# falls ein Datensatz übersprungen wird, weil er unvollständig ist:
use constant TESTUSER => { map +( $_ => undef ), qw(ipasstest) };

# Felder, die pro Stop-Datensatz genau einmal vorkommen müssen:
use constant REQUIRED_STOP_FIELDS =>
  qw(Acct-Session-Time NAS-IP-Address);

# Felder, die pro Stop-Datensatz maximal einmal vorkommen dürfen:
use constant
  OPTIONAL_STOP_FIELDS => map "Acct-$_",
  map +( "$_-Gigawords", "$_-Octets", "$_-Packets" ), DIRECTIONS;

# Felder, die entfernt werden müssen,
# um wiederholt gesendete Stop-Datensätze als solche zu erkennen:
use constant REMOVE_FIELDS_RE => qr/Acct-Delay-Time|Attr-\d+|Timestamp/;

# Zeit in Sekunden, nach der Einträge aus dem Cache entfernt werden sollen:
use constant KEEP_IN_CACHE => 90 * 86400;

# (vgl. RT#247918-55, RT#249489, RT#333375):
use constant NAS_IP_ADDRESS => {
	map( ( $_ => 1 ), split ' ', $NAS_IP_ADDRESSES ),
	map( ( $_ => undef ), split ' ', $NAS_IP_ADDRESSES_IGNORE )
};

# (Kombinationen von) Tunnel-Assignment-Id:0s und zugehörige Sub-Dienste
# sowie optional Ziele:
use constant TUNNEL_ASSIGNMENT_IDs => {
	''                    => [qw(sdsl   arcor     )],    # s. RT#415016
	'QSC-Dial-in'         => [qw(dialin           )],
	'QSC.NORIS.NET'       => [qw(sdsl   qsc       )],    # s. RT#532540
	'QSC-SDSL'            => [qw(sdsl   qsc       )],    # s. RT#430756
	'ilk-bisping'         => [qw(tdsl   tdsl-ilk  )],    # s. RT#380085-63
	'telefonica-spacenet' => [qw(sdsl   telefonica)],    # s. RT#415016
	'telefonica-zisp'     => [qw(tdsl   tdsl-zisp )],    # s. RT#245849
};

# alle Sub-Dienste, die hier verwendet werden sollen;
use constant SUBDIENSTE => qw(dialin ipass sdsl tdsl wlan);

# Ziel anhand Called-Station-Id:
use constant ZIEL_BY_CALLED_STATION_ID => {
	'08001016140' => 'tollfree',
	'06924759590' => 'local',
	''            => '?',                      # gilt auch für ipass und wlan
};

my $all_zero = sub {
	my $hashref = shift;
	$hashref->{''} && "@{ $hashref->{''} }" ne '0' and return '' for @_;
	1;
};

sub acct_radius {

	my $cachefile = "$CACHEDIR/radius";
	dbmopen my %done, $cachefile, 0600
	  or die qq(Kann "$cachefile" nicht öffnen: $!\n);

	{
		my $oldest = DoTime() - KEEP_IN_CACHE;
		$done{$_} < $oldest and delete $done{$_} for keys %done;
	}

	my ( $acct, %acct );
	for my $typ (qw(ip minuten zeit)) {
		for (SUBDIENSTE) {
			my $dienst = "$typ-$_";
			next if $typ eq 'minuten' && !defined find_dienst $dienst;
			$acct{$dienst} = do_start(
				want       => 'pers',
				dienst     => $dienst,
				quelle     => 'radius',
				logdir     => "$dienst.radius",
				do_reverse => 0
			  )
			  or die "Kein Accounting $dienst";
			$acct ||= $acct{$dienst};
		}
	}
	my %zielcode;
	for (
		values %{ +ZIEL_BY_CALLED_STATION_ID },
		map $_->[1],
		grep defined $_->[1],
		values %{ +TUNNEL_ASSIGNMENT_IDs }
	  )
	{
		$zielcode{$_} = find_descr( ziel => $_, 1 )
		  unless exists $zielcode{$_};
	}

	my $write2radacct = $ENV{TESTING2} || $acct->{quelle} !~ /^test/;
	local $/ = '';
	Record: while ( defined( my $record = get_line($acct) ) ) {
		$record =~ s/^\S.*\n//;
		my %field;
		for ( split /\n/, $record ) {
			next unless /\S/;
			my ( $key, $value ) = /^\s+(\S+) = (.*)$/ or die $_;
			$value =~ s/^"(.*)"\z/$1/;
			$value =~ s/\\([0-7]{3}|.)/ length $1 == 1 ? $1 : chr oct $1 /eg;
			push @{ $field{$key} }, $value;
		}
		my @errors;
		for (REQUIRED_FIELDS) {
			unless ( $field{$_} ) { push @errors, "$_ fehlt" }
			elsif ( @{ $field{$_} } > 1 ) {
				push @errors, "$_ kommt " . @{ $field{$_} } . 'mal vor';
			}
		}
		for (OPTIONAL_FIELDS) {
			next unless $field{$_};
			push @errors, "$_ " . @{ $field{$_} } . 'mal vorkommt'
			  if @{ $field{$_} } > 1;
		}
		if (@errors) {
			warn 'Überspringe den folgenden Datensatz, weil '
			  . join( ' und ', @errors )
			  . ":\n$record"
			  unless $field{'User-Name'}
			  && exists TESTUSER->{"@{$field{'User-Name'}}"}
			  || $all_zero->( \%field, OPTIONAL_STOP_FIELDS );
		}
		elsif ( "@{$field{'Acct-Status-Type'}}" eq 'Stop' ) {

			for (REQUIRED_STOP_FIELDS) {
				unless ( $field{$_} ) { push @errors, "$_ fehlt" }
				elsif ( @{ $field{$_} } > 1 ) {
					push @errors, "$_ kommt " . @{ $field{$_} } . 'mal vor';
				}
			}
			for (OPTIONAL_STOP_FIELDS) {
				next unless $field{$_};
				push @errors, "$_ " . @{ $field{$_} } . 'mal vorkommt'
				  if @{ $field{$_} } > 1;
			}
			if (@errors) {
				warn 'Überspringe den folgenden Stop-Datensatz, weil '
				  . join( ' und ', @errors )
				  . ":\n$record"
				  unless $field{'User-Name'}
				  && exists TESTUSER->{"@{$field{'User-Name'}}"};
				next Record;
			}

			unless ( NAS_IP_ADDRESS->{"@{$field{'NAS-IP-Address'}}"} ) {
				warn "Unbekannte NAS-IP-Address:\n$record"
				  unless exists NAS_IP_ADDRESS->{"@{$field{'NAS-IP-Address'}}"};
				next Record;
			}

			# Erkennung doppelter Datensätze:
			( my $unique = $record ) =~ s/^\s+${\REMOVE_FIELDS_RE} = .*$//gm;
			next Record if $done{$unique};
			my $timestamp = $field{Timestamp}[0];
			$timestamp -= $field{'Acct-Delay-Time'}[0]
			  if $field{'Acct-Delay-Time'};

			my ( %pakete, %bytes );
			$pakete{$_} = bignum 0 for DIRECTIONS;
			$bytes{$_}  = bignum 0 for DIRECTIONS;
			for my $dir (DIRECTIONS) {
				$pakete{$dir} += $field{"Acct-$dir-Packets"}[0]
				  if exists $field{"Acct-$dir-Packets"};
				if ( exists $field{"Acct-$dir-Gigawords"} ) {
					$bytes{$dir} += $field{"Acct-$dir-Gigawords"}[0];
					$bytes{$dir} <<= 32;
				}
				$bytes{$dir} += $field{"Acct-$dir-Octets"}[0]
				  if exists $field{"Acct-$dir-Octets"};
			}
			my ( $pakete, $bytes );
			$pakete += $pakete{$_} for DIRECTIONS;
			$bytes  += $bytes{$_}  for DIRECTIONS;

			my $sekunden = $field{'Acct-Session-Time'}[0];

			my $warn = $sekunden
			  || grep( $pakete{$_} || $bytes{$_}, DIRECTIONS )
			  ? sub { warn @_ }
			  : sub { };

			my $user = $field{'User-Name'}[0];
			my ( $subdienst, $ziel );

			if ( ( $field{'NAS-Port-Type'}[0] || '' ) eq 'Wireless-802.11' ) {
				$subdienst = 'wlan';
				$ziel      = '?';
				$user =~ s/^.*\\//;    # vgl. RT#380740-25 ff.
			}

			elsif ( ( $field{'NAS-Port-Type'}[0] || '' ) =~ /^(?:5|Virtual)\z/
				|| ( $field{'NAS-Identifier'}[0] || '' ) eq 'i-Pass VNAS' )
			{
				my %subdienst;

				if ( $user =~ s#shdsl-space/(.*)%noris\.de$#$1# ) {
					++$subdienst{sdsl};
				}
				elsif ( $user =~ s#dslflat/(.*)%\Q$WDESCR#$1# ) {
					++$subdienst{tdsl};
				}

				++$subdienst{ipass}
				  if $field{'NAS-Identifier'}
				  && "@{$field{'NAS-Identifier'}}" eq 'i-Pass VNAS';

				if (   $field{'Tunnel-Assignment-Id:0'}
					|| !keys %subdienst
					|| "@{[ keys %subdienst ]}" eq
					TUNNEL_ASSIGNMENT_IDs->{''}[0] )
				{
					my $tunnel_assignment_id_0 =
					  "@{ $field{'Tunnel-Assignment-Id:0'} || [] }";

					defined( my $subdienst_ziel =
						  TUNNEL_ASSIGNMENT_IDs->{$tunnel_assignment_id_0} )
					  or $warn->("Unbekannte Tunnel-Assignment-Id:0:\n$record"),
					  next;

					++$subdienst{ $subdienst_ziel->[0] };
					$ziel = $subdienst_ziel->[1]
					  if defined $subdienst_ziel->[1];
				}

				unless ( keys %subdienst ) {
					$warn->("Es konnte kein Dienst ermittelt werden:\n$record");
					next Record;
				}
				elsif ( keys %subdienst == 1 ) {
					($subdienst) = keys %subdienst;
				}
				else {
					$warn->(
						'Der Dienst konnte nicht eindeutig ermittelt werden ('
						  . join( ' vs. ', sort keys %subdienst )
						  . "):\n$record" );
					next Record;
				}
			}

			else {
				$warn->(
					(
						defined $field{'NAS-Port-Type'}[0]
						? "Unbekannter NAS-Port-Type: $field{'NAS-Port-Type'}[0]"
						: 'Kein NAS-Port-Type und nicht iPass'
					)
					. ":\n$record"
				);
				next Record;
			}

			$user =~ s/\@.*//;
			my $kunde = $acct{"ip-$subdienst"}{hash_uucp}{ lc $user };
			unless ($kunde) {
				$warn->(
					qq(Unbekannter User "@{$field{'User-Name'}}":\n$record));
				next Record;
			}

			unless (
				defined $ziel
				|| defined(
					$ziel = ZIEL_BY_CALLED_STATION_ID->{
						     $subdienst ne 'ipass'
						  && defined $field{'Called-Station-Id'}
						  && $field{'Called-Station-Id'}[0]
					  }
				)
			  )
			{
				$warn->("Ziel konnte nicht ermittelt werden:\n$record");
				next Record;
			}
			my $zielcode = $zielcode{$ziel};
			my $record = "# Ziel: $ziel; Zielcode: $zielcode\n$record";

			if ($write2radacct) {
				my $dienst = find_dienst("ip-$subdienst")
				  or fehler("Dienst 'ip-$subdienst' nicht gefunden");
				Do(<<_);
	INSERT INTO radacct SET
		dienst      = $dienst,
		ziel        = $zielcode,
		kunde       = $kunde,
		person      = ${\ get_person($user, undef, 2) },
		gegenstelle = ${\ qquote($field{'Calling-Station-Id'}[0]) },
		zielrufnr   = ${\ qquote($field{'Called-Station-Id' }[0]) },
		datum       = $timestamp,
		dauer       = $sekunden,
		pakete_in   = $pakete{Input},
		pakete_out  = $pakete{Output},
		bytes_in    = $bytes{Input},
		bytes_out   = $bytes{Output}
_
			}
			$done{$unique} = $timestamp;
			$acct{"ip-$subdienst"}
			  ->acct( $kunde, undef, ">$zielcode", undef, $pakete, $bytes, $record );
			$acct{"zeit-$subdienst"}
			  ->acct( $kunde, undef, ">$zielcode", undef, 1, $sekunden, $record );
			$acct{"minuten-$subdienst"}
			  ->acct( $kunde, undef, ">$zielcode", undef, 1, ceil( $sekunden / 60 ),
				$record )
			  if $acct{"minuten-$subdienst"};

		}
		elsif ( "@{$field{'Acct-Status-Type'}}" !~
			/^(?:Start|Alive|Interim-Update)\z/ )
		{
			warn "Unbekannter Acct-Status-Type:\n$record";
		}
	}
	continue {
		$/ = '';    # Workaround, s. RT#195235
	}

	dbmclose %done or warn qq(Fehler beim Schließen von "$cachefile": $!\n);
	do_end($_) for values %acct;
	undef;
}

1;
