#!/usr/bin/perl -w
#
# Copyright (c) 2001,2002
#   Chris Adams <cmadams@hiwaay.net>
#   written for HiWAAY Internet Services
#
########################################################################
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
########################################################################
#
# How it works:
# I set up my RADIUS server with everything under a common directory,
# /usr/local/radius ($RADIUS below).  Accounting records are wrtten by the
# RADIUS server into $RADIUS/radacct ($RADLOG), into the file detail ($FIFO).
# The accounting records are copied into a file ($DETAIL) and passed to a
# program (@PARSE) via a named pipe.  If the parser is not accepting records,
# only a certain number ($MAXINMEM) are held in memory before being flushed to
# a file ($FLUSH) to be handled via a cron job.  If the parser is restarted,
# the last record is re-sent in case the parser had crashed before completely
# handling that record.
#
# The parser will automatically be restarted if it crashes.  Any errors are
# logged via syslog ($LOG_FACIL).
#
# History:
# 1.0 - 2001-01-25
#       initial version
#
# 1.1 - 2001-09-23
#       bugfixes - log warnings and reset bit vector when reopening file
#
# 1.5 - 2002-02-15
#       change to non-blocking I/O
#
# 1.6 - 2002-02-18
#       fix non-blocking I/O
#
# 1.7 - 2002-03-22
#       more fixes for non-blocking I/O
#
# 2.0 - 2002-06-27
#       use better non-blocking I/O and rewrite select loop
#
# 2.1 - 2002-07-08
#       fix checking of parser process
#

use POSIX;
use Sys::Syslog qw(:DEFAULT setlogsock);
use strict;

BEGIN {
########################################################################
# Configuration stuff
#
# Syslog options
use vars qw($LOG_FACIL);
$LOG_FACIL = "local3";

# Maximum # of requests to keep in memory before flushing them to disk
use vars qw($MAXINMEM);
$MAXINMEM = 5;

# RADIUS directory
use vars qw($RADIUS $RADLOG $DETAIL);
$RADIUS = "/usr/local/radius";
$RADLOG = $RADIUS . "/radacct";
$DETAIL = $RADLOG . "/detail-%Y-%m-%d";

# Where to flush stalled requests to disk
use vars qw($FLUSH);
$FLUSH = $RADLOG . "/detail-todo";

# The parsing program
use vars qw(@PARSE);
@PARSE = ($RADIUS . "/localbin/radparse", "-e", $RADLOG . "/parse-errors",
    "-s", $RADLOG . "/parse-skips", "-l");

# The FIFO to listen to
use vars qw($FIFO);
$FIFO = $RADLOG . "/detail";

# End configuration stuff
########################################################################
}

use vars qw($debug);
$debug = 0;
if (@ARGV && ($ARGV[0] eq "-d")) {
	shift @ARGV;
	$debug = 1;
}

if (! $debug) {
	# Open syslog
	my ($name) = $0 =~ /\/([^\/]+)$/;
	setlogsock ("unix");
	openlog ($name, "pid", $LOG_FACIL);

	# Daemonize
	chdir ("/") or die "chdir /: $!\n";
	open (STDIN, "/dev/null") or die "open /dev/null: $!\n";
	open (STDOUT, "> /dev/null") or die "open > /dev/null: $!\n";
	defined (my $dpid = fork) or die "fork: $!\n";
	exit if ($dpid);
	setsid ();
	open (STDERR, ">&STDOUT");

	# Install logging handlers
	$SIG{"__WARN__"} = sub { syslog ("warning", "%s", join ("", @_)) };
	$SIG{"__DIE__"} = sub { syslog ("crit", "%s", join ("", @_)); exit 1 };
}

# Install a HUP signal handler that flushes requests and exits
$SIG{"HUP"} = sub { flushreq (); exit 0 };


# Request queue
use vars qw(@q $partial $last);
@q = ();
$partial = $last = "";

# Start the parser
use vars qw($pid $pvec $pfd $pflags $pflags_nonblock $partial);
start_parser ();

# Open the FIFO
use vars qw($fvec $ffd $fflags $fflags_nonblock);
open_fifo ();

# Now, loop and handle requests
while (1) {
	# See what is ready for work
	my $r = $fvec;
	my $w = $pvec;

	# Only look at the parser if there is a queue
	if (! @q) {
		$w = "";
	}

	# Make sure parser really is there
	if (defined ($pid) && kill (0, $pid)) {
		my $wait = waitpid ($pid, WNOHANG);
		if (defined ($wait) && ($wait == $pid)) {
			# Parser exited, restart it and don't try to write to
			# it this time through
			syslog ("notice", "parser[%d] exited: %d", $pid,
			    $? >> 8);
			start_parser ();
			$w = $pvec;
		}
	} else {
		start_parser ();
		$w = $pvec;
	}

	if (! select ($r, $w, undef, undef)) {
		die "select failed: $!\n";
	}
	if (vec ($r, $ffd, 1)) {
		# Something to read - go nonblocking and get it all
		fcntl (FIFO, F_SETFL, $fflags_nonblock) or do {
			warn "fcntl(F_SETFL,FIFO): $!\n";
			open_fifo ();
			next;
		};

		my $req;
		my $ret = sysread (FIFO, $req, PIPE_BUF);
		if (! defined ($ret)) {
			warn "read(FIFO): $!\n";
			open_fifo ();
			next;
		}

		# Return to blocking mode
		fcntl (FIFO, F_SETFL, $fflags) or do {
			warn "fcntl(F_SETFL,FIFO): $!\n";
			open_fifo ();
			next;
		};

		if ($ret) {
			# Put it on the queue to pass to the parser
			push @q, $req;

			# Write it to the normal detail file
			my $detail = strftime ($DETAIL, localtime);
			open (DETAIL, ">> $detail") or do {
				warn "open $detail: $!\n";
				next;
			};
			print DETAIL $req;
			close (DETAIL);
		}
	}
	if (vec ($w, $pfd, 1)) {
		# Parser is ready - go nonblocking and feed it
		fcntl (PARSE, F_SETFL, $pflags_nonblock) or do {
			warn "fcntl(F_SETFL,PARSE): $!\n";
			start_parser ();
			next;
		};

		while (@q) {
			my $rec = shift @q;
			my $len = length ($rec);
			my $ret = syswrite (PARSE, $rec, $len);
			$ret = 0 if (! defined ($ret) && ($! == EAGAIN));
			if (! defined ($ret)) {
				warn "write(PARSE): $!\n";
				start_parser ();
				last;
			} elsif ($ret < $len) {
				# Wrote a partial record; save the rest
				$partial = $rec;
				my $rest = substr ($rec, $ret);
				unshift @q, $rest;
				last;
			} else {
				# No partial record left hanging
				$partial = "";
				# Save the last record sent
				$last = $rec;
			}
		}

		# Return to blocking mode
		fcntl (PARSE, F_SETFL, $pflags) or do {
			warn "fcntl(F_SETFL,PARSE): $!\n";
			start_parser ();
			next;
		};
	}

	# If there are still pending requests and there are more than there
	# should be, flush to disk
	flushreq () if (scalar (@q) > $MAXINMEM);
}


sub flushreq
{
	return if (! @q);

	local (*F);
	open (F, ">> $FLUSH") or die "open $FLUSH: $!\n";

	if ($partial) {
		# Partial record was sent, flush the whole thing
		shift @q;
		unshift @q, $partial;
	}
	# Flush the last complete record as well
	unshift @q, $last if ($last);

	print F join ("", @q);
	close (F);
	@q = ();
}


sub start_parser
{
	use vars qw($last_start);

	BEGIN {
		$last_start = 0;
	}

	if ((time - $last_start) < 10) {
		# Don't start the parser more than once every 10 seconds
		close (PARSE) if (defined (fileno (PARSE)));
		kill (SIGKILL, $pid) if ($pid);
		$pid = 0;
		$pvec = "";
		$pfd = 0;
		return;
	}

	# Fork and run the parser
	close (PARSE) if (defined (fileno (PARSE)));
	kill (SIGKILL, $pid) if ($pid);
	die "Can't fork: $!" unless defined ($pid = open (PARSE, "|-"));
	if (! $pid) {
		exec @PARSE or exit 1;
	}
	my $oldfd = select (PARSE);
	$| = 1;
	select ($oldfd);

	$pvec = "";
	$pfd = fileno (PARSE);
	vec ($pvec, $pfd, 1) = 1;

	# Get the status flags and make sure we're nonblocking
	my $f = "";
	fcntl (PARSE, F_GETFL, $f) or do {
		warn "fcntl(F_GETFL,PARSE): $!\n";
		close (PARSE);
		kill (SIGKILL, $pid);
		$pid = 0;
		$pvec = "";
		return;
	};
	$pflags = pack ("i", unpack ("i", $f) & ~O_NONBLOCK);
	fcntl (PARSE, F_SETFL, $pflags) or do {
		warn "fcntl(F_SETFL,PARSE): $!\n";
		close (PARSE);
		kill (SIGKILL, $pid);
		$pid = 0;
		$pvec = "";
		return;
	};
	$pflags_nonblock = pack ("i", unpack ("i", $pflags) | O_NONBLOCK);

	# Any time we restart the parser, resend the last record through it
	# again in case it crashed before handling it
	if ($partial) {
		shift @q;
		unshift @q, $partial;
		$partial = "";
	}
	if ($last) {
		unshift @q, $last;
		$last = "";
	}

	# Save the start time
	$last_start = time;
}


sub open_fifo
{
	use vars qw($last_open);

	BEGIN {
		$last_open = 0;
	}

	if ((time - $last_open) < 10) {
		# Don't open the FIFO more than once every 10 seconds
		close (FIFO) if (defined (fileno (FIFO)));
		close (FIFOWR) if (defined (fileno (FIFOWR)));
		$fvec = "";
		$ffd = 0;
		return;
	}

	# Make sure the FIFO exists and is a FIFO
	if (! -e $FIFO) {
		mkfifo ($FIFO, 0600) or do {
			warn "Can't create $FIFO: $!\n";
			return;
		};
	} elsif (! -p $FIFO) {
		warn "$FIFO exists but is not a FIFO\n";
		return;
	}

	# Open it nonblocking (so we don't hang here waiting for a writer)
	sysopen (FIFO, $FIFO, O_RDONLY | O_NONBLOCK) or do {
		warn "open(FIFO): $!\n";
		return;
	};

	$fvec = "";
	$ffd = fileno (FIFO);
	vec ($fvec, $ffd, 1) = 1;

	# Get the status flags and make sure we're nonblocking
	my $f = "";
	fcntl (FIFO, F_GETFL, $f) or do {
		warn "fcntl(F_GETFL,FIFO): $!\n";
		close (FIFO);
		close (FIFOWR);
		$fvec = "";
		return;
	};
	$fflags = pack ("i", unpack ("i", $f) & ~O_NONBLOCK);
	fcntl (FIFO, F_SETFL, $fflags) or do {
		warn "fcntl(F_SETFL,FIFO): $!\n";
		close (FIFO);
		close (FIFOWR);
		$fvec = "";
		return;
	};
	$fflags_nonblock = pack ("i", unpack ("i", $fflags) | O_NONBLOCK);

	# Hack: open the FIFO for writing too, so someone is always waiting
	# Otherwise, select returns ready for read but read returns EOF
	sysopen (FIFOWR, $FIFO, O_WRONLY) or do {
		warn "open(FIFOWR): $!\n";
		close (FIFO);
		$fvec = "";
		return;
	};

	# Save the open time
	$last_open = time;
}