1 files changed, 102 insertions, 0 deletions
diff --git a/perl/sentry.pl b/perl/sentry.pl
new file mode 100755
index 0000000..bc4788c
--- /dev/null
+++ b/perl/sentry.pl
@@ -0,0 +1,102 @@
+#!/usr/bin/perl
+
+# Given a bunch of IP's figure out how fast you can look up their
+#   regions and then determine how good we are at this.
+
+use locale;
+use DBI;
+use Data::Dumper;
+use LWP;
+use LWP::UserAgent;
+use Config::Tiny;
+
+$ua = LWP::UserAgent->new;
+$ua->timeout(4);
+$ua->agent("Gentoo Mirror Monitor/1.0");
+
+my $DEBUG = 1;
+my %products = ();
+my %oss = ();
+my $Config = Config::Tiny->read( 'db.conf' );
+
+# Some db credentials
+my $host = $Config->{database}->{host};
+my $user = $Config->{database}->{user};
+my $pass = $Config->{database}->{pass};
+my $db = $Config->{database}->{db};
+
+my $dbh = DBI->connect( "DBI:mysql:$db:$host",$user,$pass) or die "Connecting : $dbi::errstr\n";
+$location_sql = qq{SELECT * FROM mirror_locations JOIN mirror_products USING (product_id) WHERE product_priority > 0 ORDER BY product_priority DESC};
+#$mirror_sql = qq{SELECT * FROM mirror_mirrors WHERE mirror_active IN ('1') ORDER BY mirror_rating DESC, mirror_name};
+$mirror_sql = qq{SELECT * FROM mirror_mirrors WHERE mirror_active IN ('1') ORDER BY RAND()};
+$update_sql = qq{REPLACE mirror_location_mirror_map SET location_id=?,mirror_id=?,location_active=?};
+
+my $location_sth = $dbh->prepare($location_sql);
+my $mirror_sth = $dbh->prepare($mirror_sql);
+my $update_sth = $dbh->prepare($update_sql);
+
+# populate a product and os hash if we're debugging stuff
+#  this way we don't have to make too many selects against the DB
+if ( $DEBUG ) {
+	print "Getting raw\n";
+	my $product_sql = qq{SELECT * FROM mirror_products};
+	my $oss_sql = qq{SELECT * FROM mirror_os};
+
+	my $product_sth = $dbh->prepare($product_sql);
+	$product_sth->execute();
+
+	while ( my $product = $product_sth->fetchrow_hashref() ) {
+		$products{$product->{product_id}} = $product->{product_name};
+	}
+
+	$oss_sth = $dbh->prepare($oss_sql);
+        $oss_sth->execute();
+
+        while ( my $os = $oss_sth->fetchrow_hashref() ) {
+                $oss{$os->{os_id}} = $os->{os_name};
+        }
+}
+
+# let's build the location information
+print "Building location info\n";
+$location_sth->execute();
+my @locations = ();
+
+while (my $location = $location_sth->fetchrow_hashref() ) {
+	push(@locations, $location);
+}
+
+print "Building location info\n";
+$mirror_sth->execute();
+
+while (my $mirror = $mirror_sth->fetchrow_hashref() ) {
+	print "Testing $mirror->{mirror_baseurl}\n";
+
+	foreach my $location (@locations) {
+		my $req = HTTP::Request->new(HEAD => $mirror->{mirror_baseurl} . $location->{location_path});
+		my $res;
+		#next if !($location->{location_path} =~ /2009/);
+		#next if !($location->{location_path} =~ /10.0\//);
+		$res = $ua->request($req);
+
+		if ( $res->{_rc} == 200 ) {
+			print "$mirror->{mirror_name} for $products{$location->{product_id}} on $oss{$location->{os_id}} is okay.\n" if $DEBUG;
+			$update_sth->execute($location->{location_id}, $mirror->{mirror_id}, '1');
+		}
+		else {
+			print "$mirror->{mirror_name} for $products{$location->{product_id}} on $oss{$location->{os_id}} FAILED.\n" if $DEBUG;
+			$update_sth->execute($location->{location_id}, $mirror->{mirror_id}, '0');
+		}
+
+		# content-type == text/plain hack here for Mac dmg's
+		#if ( $location->{os_id} == 4 ) {
+		#	print "Testing: $products{$location->{product_id}} on $oss{$location->{os_id}} content-type: " .
+        #        $res->{_headers}->{'content-type'} . "\n" if $DEBUG;
+		#	if ( $res->{_headers}->{'content-type'} !~ /application\/octet-stream/ &&
+        #            $res->{_headers}->{'content-type'} !~ /application\/x-apple-diskimage/ ) {
+		#		print "$mirror->{mirror_name} for $products{$location->{product_id}} on $oss{$location->{os_id}} FAILED due to content-type mis-match.\n" if $DEBUG;
+	    #        $update_sth->execute($location->{location_id}, $mirror->{mirror_id}, '0');
+		#	}
+		#}
+	}
+}