Add update-pinger-cache

1 files changed, 156 insertions, 0 deletions

diff --git a/bin/update-pinger-cache b/bin/update-pinger-cache
new file mode 100755
index 0000000..6c434d9
--- /dev/null
+++ b/bin/update-pinger-cache
@@ -0,0 +1,156 @@
+#!/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: