#!/usr/bin/perl -w
#
# Copyright (c) 2002
#   Chris Adams <cmadams@hiwaay.net>
#
########################################################################
# 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.
########################################################################
#
# This proxies NNTP commands, caching the results of XOVER commands to speed
# up theading operations.
#
# This should be named "cache-<client>.pl", where "<client>" is the name of
# your news client (trn, tin, etc.).  Any arguments will be passed to the news
# client.
#
# Overviews are cached in $HOME/News/.overviews.  If you unsubscribe from a
# group, you'll need to remove the <group>.db file yourself.
#
# This is tested with trn 4.0-test76.
#
# History:
# 1.0 - 2002-07-03
#	initial version
#
# 1.1 - 2002-07-05
#	add communication logging for debugging
#	turn off autoflush and flush explicitly only when needed
#	handle QUIT command better (trn may send it when not really quitting)
#
# 1.2 - 2002-07-09
#	if we are disconnected from the server, disconnect the client as well
#	(because otherwise the client thinks we should remember our state)
#
# 1.3 - 2002-07-12
#	more fixes for client and server disconnects
#
# 1.4 - 2003-05-07
#	really fix QUIT handling
#
# 1.5 - 2004-05-28
#	kill LISTGROUP command (even if the server supports it)
#

use IO::Socket::INET;
use DB_File;
use POSIX qw(:errno_h);
use Fcntl qw(:DEFAULT :flock);
use strict;

# Where to store data
use vars qw($STORE);
$STORE = $ENV{"HOME"} . "/News/.overviews";

# Timeout when waiting for lock
use vars qw($TIMEOUT);
$TIMEOUT = 10;

# Debugging?
use vars qw($D);
$D = 0;

# NNTP server and port
use vars qw($nntpserver $nntpport);
if ($ENV{"NNTPSERVER"}) {
	$nntpserver = $ENV{"NNTPSERVER"};
} elsif (-f "/usr/local/etc/nntpserver") {
	open (F, "/usr/local/etc/nntpserver") and do {
		$nntpserver = <F>;
		chomp $nntpserver;
		close (F);
	}
} elsif (-f "/etc/nntpserver") {
	open (F, "/etc/nntpserver") and do {
		$nntpserver = <F>;
		chomp $nntpserver;
		close (F);
	}
} else {
	$nntpserver = "news";
}
if ($nntpserver =~ /(.*)[;:](\d+)$/) {
	$nntpserver = $1;
	$nntpport = $2;
} else {
	$nntpport = 119;
}

# Find the client command
my ($cmd) = $0 =~ /cache-([^\/]+)\.pl$/;
my @client = ($cmd, @ARGV);
@ARGV = ();

# Create an initial connection to the NNTP server
use vars qw($nntpbanner $srv $port);
nntpconnect ();

# Set up listener
my $listen = nntplisten ();
$ENV{"NNTPSERVER"} = "localhost";
$ENV{"NNTPPORT"} = $port;
if ($cmd eq "trn") {
	$ENV{"NNTPSERVER"} = "localhost;" . $port;
}

# Call the news client
die "fork: $!\n" unless (defined (my $pid = fork));
if (! $pid) {
	undef $listen;
	exec @client or die "exec: $!\n";
}
open (STDIN, "/dev/null") or die "open(/dev/null): $!\n";
open (STDOUT, "> /dev/null") or die "open(>/dev/null): $!\n";

# Set up for debugging
if ($D) {
	open (LOG, ">log");
	my $fh = select (LOG);
	$| = 1;
	select ($fh);
}

# Make sure the overviews directory exists and change to it
if (! -d $STORE) {
	mkdir ($STORE) or die "mkdir($STORE): $!\n";
}
chdir ($STORE) or die "chdir($STORE): $!\n";

# Set up some signal handlers
$SIG{"__DIE__"} = sub { warn "\n\ncache exiting\n", $@, "\n\n";
    waitpid ($pid, 0); exit ($? >> 8) };
$SIG{"CHLD"} = sub { warn "\n\nchild exited\n\n"; $SIG{"__DIE__"} = "DEFAULT";
    nntpclose (); waitpid ($pid, 0); exit ($? >> 8) };
$SIG{"INT"} = $SIG{"QUIT"} = "IGNORE";

# Accept the client connect and stop listening for new connections
my $client = $listen->accept or die "accept: $!\n";
$listen = undef;
$client->autoflush (0);
print LOG "|", $nntpbanner if ($D);
$client->printflush ($nntpbanner) or die "client: $!\n";

# Now listen for commands from the client and relay them
use vars qw($group %XOVER $XOVER);
my $fds = "";
vec ($fds, $client->fileno, 1) = 1;
my $ret;
my $ncmd;
while (defined ($ret = select ((my $x = $fds), undef, undef, undef))) {
	# If the connection is gone, quit
	if (! $client->connected) {
		warn "\n\nclient disconnected\n\n";
		last;
	}

	# If we didn't get any FDs ready, quit
	if ($ret != 1) {
		warn "\n\nselect failed (\$ret = $ret): $!\n";
		chomp $ncmd;
		chomp $ncmd;
		warn "last command was \"$ncmd\"\n";
		last;
	}

	# Get a client command
	$ncmd = $client->getline;
	print LOG ">", $ncmd if ($D);

	# Check to see if we handle the command special
	if ($ncmd =~ /^xover (.+)\r\n/i) {
		# Do this one ourselves
		nntpxover ($client, $1) && next;
	} elsif (lc ($ncmd) =~ /^listgroup/) {
		# Pretend this doesn't work
		$client->printflush ("500 command not recognized\r\n");
		next;
	} elsif (lc ($ncmd) eq "quit\r\n") {
		# Close the server
		nntpclose ();

		# Start listening again, send close, and wait for new connect
		my $listen = nntplisten ();
		print LOG "|205 goodbye\r\n" if ($D);
		$client->printflush ("205 goodbye\r\n");
		$client = undef;

		$client = $listen->accept;
		$listen = undef;
		$client->autoflush (0);
		print LOG "|", $nntpbanner if ($D);
		$client->printflush ($nntpbanner) or die "client: $!\n";

		$fds = "";
		vec ($fds, $client->fileno, 1) = 1;
		next;
	}

	# If the connection to the server is gone, reopen it
	nntpconnect () if (! $srv || ! $srv->connected);

	# Send it to the server
	$srv->printflush ($ncmd);

	# Get a server response and send it to the client
	my $resp = $srv->getline;
	print LOG "<", $resp if ($D);
	$client->printflush ($resp);

	# Handle special responses
	if ($resp =~ /^2\d\d.*follow/i) {
		# Multi-line response
		while (my $l = $srv->getline) {
			print LOG "<", $l if ($D);
			$client->print ($l);
			last if ($l =~ /^\.\r\n/);
		}
		$client->flush;
	} elsif ($resp =~ /^3\d\d send article/i) {
		# Multi-line command
		while (my $l = $client->getline) {
			print LOG ">", $l if ($D);
			$srv->print ($l);
			last if ($l =~ /^\.\r\n/);
		}
		$srv->flush;
	}
	if ($ncmd =~ /^group (.+)\r\n/i) {
		my $g = $1;
		if ($resp =~ /^2\d\d \d+ (\d+)/) {
			my $low = $1;

			# Keep track of the current group and open XOVER
			$group = $g;
			openxover ($low);
		}
	}
}

# Wait for the client to exit
warn "\n\nwaiting for child to exit\n\n";
wait;
exit ($? >> 8);


# Connect to the NNTP server
sub nntpconnect
{
	# If we've still got a connection, close it
	nntpclose () if ($srv && $srv->connected);

	# Open the connection
	$srv = new IO::Socket::INET (PeerAddr => $nntpserver,
	    PeerPort => $nntpport, Proto => "tcp", Timeout => 60)
	    or die "connect($nntpserver): $!\n";
	$srv->autoflush (0);

	# Swallow the banner line
	$nntpbanner = $srv->getline;
	die "Unknown banner: $nntpbanner\n" if ($nntpbanner !~ /^2\d\d /);

	# If we've got a group, go ahead and get back in it
	if ($group) {
		print LOG "|>mode reader\r\n" if ($D);
		$srv->printflush ("mode reader\r\n");
		my $res = $srv->getline;
		print LOG "|<", $res if ($D);
		if ($res !~ /^2\d\d/) {
			die "mode reader returned $res\n";
		}

		print LOG "|>group $group\r\n" if ($D);
		$srv->printflush ("group " . $group . "\r\n");
		$res = $srv->getline;
		print LOG "|<", $res if ($D);
		if ($res !~ /^2\d\d/) {
			die "group $group returned $res\n";
		}
	}
}


# Listen for incoming NNTP connect(s)
sub nntplisten
{
	# Connect args
	my %args = (LocalAddr => "127.0.0.1", Proto => "tcp", Listen => 1,
	    Timeout => 0, ReuseAddr => 1);

	# If the port is already set, reuse it
	if ($port) {
		$args{"LocalPort"} = $port;
	}

	# Create the listener and save the port
	my $listen = new IO::Socket::INET (%args)
	    or die "listen: $!\n";
	$port = $listen->sockport;

	# New connection -> no state
	$group = "";

	return ($listen);
}


# Close the NNTP server connection nicely
sub nntpclose
{
	return if (! $srv || ! $srv->connected);
	print LOG "|>quit\r\n" if ($D);
	$srv->printflush ("quit\r\n");
	my $l = $srv->getline;
	print LOG "|<", $l if ($D);
	$srv = undef;
}


# Handle XOVER command
sub nntpxover
{
	my ($client, $range) = @_;

	# Find the article number range
	my $start = my $end = 0;
	if ($range =~ /(\d+)-(\d+)/) {
		$start = $1;
		$end = $2;
	} elsif ($range =~ /^(\d+)$/) {
		$start = $end = $1;
	} elsif ($range =~ /(\d+)-$/) {
		$start = $1;
		print LOG "|>list active $group\r\n" if ($D);
		$srv->printflush ("list active " . $group . "\r\n");
		my $res = $srv->getline;
		print LOG "|<", $res if ($D);
		if ($res =~ /^2\d\d.*follows/i) {
			while (my $l = $srv->getline) {
				print LOG "|<", $l if ($D);
				$res .= $l;
				last if ($l =~ /^\.\r\n/);
			}
		}
		if ($res =~ /\n$group (\d+) \d+\r/) {
			$end = $1 + 0;
		}
	}
	if (! $start || ! $end) {
		# False return means do the command "normally"
		# 'cause we can't figure it out
		return undef;
	}

	# Figure out what we don't already have cached
	my @fetch = ();
	my $fstart = my $fend = 0;
	for (my $i = $start; $i <= $end; $i ++) {
		if (! defined ($XOVER{$i})) {
			$fstart = $i if (! $fstart);
			if ($fend && ($i != ($fend + 1))) {
				# Non-contiguous range to be fetched
				push @fetch, $fstart . "-" . $fend;
				$fstart = $fend = $i;
			} else {
				$fend = $i;
			}
		}
	}
	if ($fstart && $fend) {
		push @fetch, $fstart . "-" . $fend;
	}

	# Fetch the missing data
	my $min = $XOVER{"min"} || 0;
	foreach my $fetch (@fetch) {
		nntpconnect () if (! $srv || ! $srv->connected);
		print LOG "|>xover $fetch\r\n" if ($D);
		$srv->printflush ("xover ". $fetch . "\r\n");
		my $res = $srv->getline;
		print LOG "|<", $res if ($D);
		if ($res =~ /^2\d\d.*follow/i) {
			while (my $l = $srv->getline) {
				print LOG "|<", $l if ($D);
				last if ($l =~ /^\.\r\n/);
				my ($i) = $l =~ /^(\d+)/;
				next if (! $i);
				$XOVER{$i} = $l;
				$min = $i if (! $min || ($min > $i));
			}
		}
	}
	$XOVER{"min"} = $min;
	$XOVER->sync;

	# Now send everything to the client
	print LOG "|224 overviews follows\r\n" if ($D);
	$client->print ("224 overviews follows\r\n");
	for (my $i = $start; $i <= $end; $i ++) {
		next if (! defined ($XOVER{$i}));
		print LOG "|", $XOVER{$i} if ($D);
		$client->print ($XOVER{$i});
	}
	print LOG "|.\r\n" if ($D);
	$client->printflush (".\r\n");

	return 1;
}


# Open XOVER cached data
sub openxover
{
	my ($min) = @_;

	local (*LOCK);

	# If there's already an open db, close it
	if (%XOVER) {
		$XOVER = undef;
		untie %XOVER;
		flock (LOCK, LOCK_UN);
		close (LOCK);
	}

	my $dbfile = $group . ".db";

	# If the file doesn't exist, try to create an empty database
	if (! -f $dbfile) {
		tie (%XOVER, 'DB_File', $dbfile, O_RDWR | O_CREAT | O_EXCL,
		    0666, $DB_HASH)
		    or do { die "creat($dbfile): $!" if ($! != EEXIST) };
		untie (%XOVER);
	}

	# Get an exclusive lock on the file
	sysopen (LOCK, $dbfile, O_RDWR) or die "open($dbfile): $!\n";
	my $locked = 0;
	local $SIG{"ALRM"} = 'IGNORE';
	eval {
		local $SIG{"ALRM"} = sub { die "timed out!\n"; };
		alarm ($TIMEOUT);

		if (flock (LOCK, LOCK_EX)) {
			$locked = 1;
		} else {
			die "flock($dbfile): $!\n";
		}
		alarm (0);
	};
	alarm (0);
	die "lock($dbfile): $@" if (! $locked);

	# Open the database
	$XOVER = tie (%XOVER, 'DB_File', $dbfile, O_RDWR, 0, $DB_HASH)
	    or die "tie($dbfile): $!\n";

	# Clean up any old XOVER data
	my $omin = $XOVER{"min"};
	if (! defined ($omin)) {
		$XOVER{"min"} = $min;
	} elsif ($omin < $min) {
		for (my $i = $omin; $i < $min; $i ++) {
			delete $XOVER{$i};
		}
		$XOVER{"min"} = $min;
	}
	$XOVER->sync;
}