#!/usr/bin/perl -w

#   update-pinger-cache: (c) 2002, 2004 Peter Palfrader <peter@palfrader.org>
#   $Id$

=pod

=head1 NAME

update-pinger-cache		Fetch new reliability stats

=over

=head1 SYNOPSIS

=item B<update-pinger-cache>

=back

=head1 DESCRIPTION

FIXME

=back

=head1 BUGS

Please report them to the author.

=head1 AUTHOR

Peter  Palfrader, E<lt>peter@palfrader.orgE<gt>

=cut

use strict;
use English;
use LWP::UserAgent;
use IO::File;
use Date::Parse;
use Carp;

$ENV{'PATH'} = '/bin:/usr/bin';
delete @ENV{'IFS', 'CDPATH', 'ENV', 'BASH_ENV'};

my $CONFIG = {
	#allpingers => 'allpingers/allpingers.txt',
	#outdir => 'meta/',
	useragent_timeout => 120,
	timeout => 130,
	old => 24 * 60 * 60,
};

$CONFIG->{'allpingers'} = shift @ARGV;
$CONFIG->{'outdir'} = shift @ARGV;
die ("Usage: $PROGRAM_NAME <allpingersfile> <outdir>\n") if (!defined $CONFIG->{'outdir'} || scalar @ARGV > 0);

my $user_agent =
	LWP::UserAgent->new(env_proxy => 1,
	                    keep_alive => 1,
	                    timeout => $CONFIG->{'useragent_timeout'} );

sub store_content($$$$) {
	my ($content_or_error, $site_taint, $type_taint, $content) = @_;
	my ($site) = $site_taint =~ /^([a-zA-Z0-9]+)$/;
	my ($type) = $type_taint =~ /^([a-zA-Z0-9]+)$/;
	return undef unless defined $site;
	return undef unless defined $type;

	my $write = $content_or_error eq 'content' ? 'cache' :
	            $content_or_error eq 'error'   ? 'error' :
	            die ("Unepxected value of content_or_error: $content_or_error");
	my $unlink = $content_or_error eq 'content' ? 'error' :
	             $content_or_error eq 'error'   ? 'cache' :
	             die ("Unepxected value of content_or_error: $content_or_error");

	open(F, '>',$CONFIG->{'outdir'}.'/'.$write.'.'.$site.'.'.$type.'.txt') or die ("Could not open outdir: $!\n");
	print(F $content) or die ("Could not write to outfile: $!");
	close(F) or die ("Could not close outfile: $!");
	unlink($CONFIG->{'outdir'}.'/'.$unlink.'.'.$site.'.'.$type.'.txt') if -e $CONFIG->{'outdir'}.'/cache.'.$site.'.'.$type.'.txt';
	return 1;
};

my @CHILDREN;

sub get_stats($$$) {
	my ($site, $type, $value) = @_;
	return undef unless defined $value;

	my $uri = URI->new($value);
	if ($user_agent->is_protocol_supported( $uri )) {
		my $pid = fork();
		die "Can't fork: $!" unless defined $pid;
		unless ($pid) {
			eval{
				local $SIG{ALRM} = sub { die "alarm\n" };
				alarm $CONFIG->{'timeout'};
				my $response = $user_agent->get($value);
				if ($response->is_success) {
					my $content = $response->content;
					$content =~ s/\r\n/\n/g;
					store_content('content', $site, $type, $content);
				} else {
					store_content('error', $site, $type, "Error: ".$response->status_line());
				};
				alarm 0;
			};
			if ($EVAL_ERROR) {
				if ($EVAL_ERROR eq "alarm\n") {
					store_content('error', $site, $type, "Timeout");
				} else {
					store_content('error', $site, $type, "Error: $EVAL_ERROR");
					die unless $EVAL_ERROR eq "alarm\n";
				};
			};
			exit;
		} else {
			push @CHILDREN, $pid;
		};
	} else {
		warn ("$PROGRAM_NAME: Protocol for '$value' is not supported\n");
		store_content('error', $site, $type, "Error: Protocol for '$value' is not supported");
	};
};


# Read Pinger URLs and get stats (forked)
my %pinger_uris;
my %type_fhs;
{
	my $source;
	open (F, $CONFIG->{'allpingers'}) or die ("Could not open allpingers '$CONFIG->{'allpingers'}': $!\n");
	while(<F>) {
		s/\s*(.*)\s*/$1/;
		next if (/^\s*#/);
		$source = $1, next if (/^\[(.*)\]$/);
		if (/(.+?)\s*=\s*(.+)/) {
			$pinger_uris{$source}->{$1} = $2 if defined $source;
		};
	};
	for $source (sort keys %pinger_uris) {
		my $uris = $pinger_uris{$source};
		get_stats($source, 1, $uris->{'rlist2'} || $uris->{'rlist2_html'} || $uris->{'rlist'} || $uris->{'rlist_html'});
		get_stats($source, 2, $uris->{'mlist2'} || $uris->{'mlist2_html'} || $uris->{'mlist'} || $uris->{'mlist_html'});
	};
};

for (@CHILDREN) {
	waitpid($_, 0);
};

open(F, '>',$CONFIG->{'outdir'}.'/stamp-cache') or die ("Could not open <outdir>/stamp-cache: $!\n");
close(F);

# vim:set ts=4:
# vim:set shiftwidth=4: