#! /usr/bin/perl
# anders@aftenposten.no, 2008-08-06
# Check that an URL can actually be purged after fetching it from a cache server

use Sys::Hostname;
use IO::Socket;
use Getopt::Std;

getopts('H:u:c:x:');

sub usage {
	print "Usage: check_http_purge -H <hostname> -u <url> -c <expected http code> -x <ignore http code>\n\n";
	print "Both -c and -x can have comma separated lists of http codes.\n";
	exit(1);
}

usage unless ($opt_H && $opt_u && $opt_c);

if ($opt_H =~ /:\d+$/) {
	$host = $opt_H;
} else {
	$host = $opt_H . ":80";
}
$vhost = $opt_u;
$vhost =~ s@^\w+://(.+?)/.*@\1@;
$baseurl = $opt_u;
$baseurl =~ s@^\w+://.+?(/)@\1@;

sub geturl {
	my $data;
	my $sock = new IO::Socket::INET (
				PeerAddr => $host,
				Proto => 'tcp',
				Timeout => 10
				);
	return(0) unless ($sock);
	print $sock "GET $baseurl HTTP/1.1\nHost: $vhost\nConnection: close\n\n";
	while (<$sock>) {
		$data .= $_;
	}
	close($sock);
}

sub ckpurge {
	my $data;
	my $sock = new IO::Socket::INET (
				PeerAddr => $host,
				Proto => 'tcp',
				Timeout => 10
				);
	return(0) unless ($sock);
	print $sock "PURGE $baseurl HTTP/1.1\nHost: $vhost\nConnection: close\n\n";
	while (<$sock>) {
		$data .= $_;
	}
	close($sock);

	my @response = split(/\n/, $data);
	$httpresponse = $response[0];
	chomp($httpresponse);
	$httpresponse =~ s@\r@@g;
	$httpcode = $httpresponse;
	$httpcode =~ s@^HTTP/[\d\.]+ (\d+).*@$1@g;
}

geturl;
ckpurge;

foreach $hc (split /,/, $opt_c) {
	if ($httpcode == $hc) {
		print "PURGE of URL $opt_u returned $httpresponse, fine.\n";
		exit(0);
	}
}

if ($opt_x) {
	foreach $hc (split /,/, $opt_x) {
		if ($httpcode == $hc) {
			print "PURGE of URL $opt_u returned $httpresponse, OK (excluded).\n";
			exit(0);
		}
	}
}

if ($opt_x) {
	print "PURGE of URL $opt_u returned $httpresponse, expected $opt_c (and excluding $opt_x).\n";
} else {
	print "PURGE of URL $opt_u returned $httpresponse, expected $opt_c.\n";
}
exit(2);