#!/usr/bin/perl
use DBI;
use Cache::Memcached;
use POSIX qw(floor);
$|++;

my $debug = 0;
open(LOG, ">/tmp/redir.debug") if ($debug);

# Connect to database
$dbh = DBI->connect('DBI:mysql:hidefs:i-alias-hidefs', 'hidefs', 'hidefs'),
	{ PrintError => 1};
die ("Cannot connect to DB: $DBI::errstr") unless $dbh;
$dbh->{mysql_auto_reconnect} = 1;

# Connect to memcache
# Note: Enabling debug on memcache is a great way to debug
# the whole script :)
$memd = new Cache::Memcached {
	'servers'	=> [ 'i-storage1:11211', 'i-storage2:11211' ],
	'namespace'	=> 'redir:',
	'debug'		=> 0
};

# Prepare our key lookup query ahead of time
my $keyq = $dbh->prepare(
	"select concat('http://',B.lan_address,':', B.lan_port, '/disk', D.id, ".
	"'/', I.kee) as uri from boxes B, disks D, domains DM, items I where ".
	"B.state='up' AND B.id=D.box_id and D.state='up' AND ".
	"D.domain_id=DM.id AND I.disk_id=D.id AND DM.name=? AND I.kee=?"
	);

my $symq = $dbh->prepare("SELECT dest from symlinks where domain=? and src=?");
my $analbq = $dbh->prepare("SELECT lan_address from boxes where state='down'");
my $analdq = $dbh->prepare("SELECT id from disks where state='down'");

# Slurp in URLs from squid
REQUEST:
while(<>) {
	chomp;
	my ($domain, $key, @paths, $query, $ret);

	# url = http://host/path/to/file
	# path = path/to/file
	my $url = (split())[0];
	my $path = (split(/\//, $url, 4))[3];

	dbg("PATH=$path\n");
	
	$_ = $path;
	if (m!^img/../(.+)!i) {
		$domain = 'images';
		$key = $1;
	}
	elsif (m!^img/scaled/../(.+)!i) {
		# ABCD-scaled.jpg
		my ($file, $ext) = split(/\./, $1);
		$domain = 'images';
		$key = $file . '-scaled.' . $ext;
	}
	elsif (m!movies/../(.+)$!i) {
		$domain = 'movies';
		$key = $1;
		($key, $query) = ($1, $2) if ($key =~ /(.+)\?(.+)/);
		$key = movie_auth($key);
	}
	elsif (m!(.)thumbs/../(.+)!i) {
		# ABCD-s.jpg | ABCD-l.jpg
		my $t = $1;
		my ($file, $ext) = split(/\./, $2);
		$domain = "thumbs";
		$key = $file . '-' . $t . '.' . $ext;
	}

	# Hotlink is always a special case. Sigh.
	elsif (m!^hotlink/../(.+)!i) {
		s/\-scaled//g;
		s/\-h//g;
		my ($file, $ext) = split(/\./, $1);
		$domain = "images";
		$key = $file . '-h.' . $ext;
		if (!getpaths($domain, $key)) {
			print("http://hidebehind.com/hotlink2.php?iid=$file.$ext\n");
			next REQUEST;
		}
	}

	else { print "$url\n"; next; }

	@paths = getpaths($domain, $key);
	if (!@paths) { print "$url\n"; next; }

	# Pick a random path from the list
	$ret = $paths[ int( rand(scalar(@paths)) ) ];

	if ($query) {
		print $ret . '?' . $query . "\n";
	}
	else {
		print "$ret\n";
	}
}


# Returns a list of URL's to a key, undef on failure.
# Uses memcache for both positive and negative cache
sub getpaths {
	my ($domain, $key) = @_;
	my @ret;

	dbg("GETPATHS $domain $key\n");

	# Bleh to memcache datatype limitations.
	# If it's in memcache, positive or negative, we're already done.
	@ret = split(/!/, $memd->get($key));
	if (@ret) {
		return(undef) if ($ret[0] eq "N");
		return(anal_filter(@ret));
	}

	# Look it up in DB
	@ret = getpaths_db($domain, $key);

	# If we couldn't find it..
	# Check for symlinks and retry
	if (!@ret) {
		my @data;
		$symq->execute($domain, $key);
		$data = $symq->fetchrow();
		dbg("SYM: $data\n");
		@ret = getpaths_db($domain, $key);
	}

	dbg('RET: '. @ret . "\n");

	if (@ret) { $memd->set($key, join('!', @ret), 3600); } 
	else {      $memd->set($key, 'N', 30); }

	return(@ret);
}

# Look up the paths from the DB.
# Returns a list, or undef on failure.
sub getpaths_db {
	my ($domain, $key) = @_;
	my @ret;

	$keyq->execute($domain, $key);
	while ($data = $keyq->fetchrow()) { 
		push @ret, $data;
	}
	
	return(@ret);
}

# Authenticates a movie based on our funny alg
# Returns actual filename to use.
sub movie_auth {
	my $file = $_[0];
	my $auth;
	my $now = time();
	my $authperiod = 1200;

	# Processing.flv is linked to this codename
	return("78ED53.flv") if ($file =~ /process/);

	if ($file =~ /^([0-9A-F]{6})([0-9A-F]*)\.flv/) {
		$file = $1;
		$auth = $2;
		dbg("MA REGEX MATCH: $file $auth\n");
	}

	if (!validate_movie_auth($file, $auth)) {
		dbg("AUTHFAIL\n");
		$file = "99BDD2";
	}

	return("$file.flv");
}

# Checks a movie's auth code
sub validate_movie_auth {
        my ($codename, $auth) = @_;
        my $now = time();
        my $fl = floor(time()/1200);

	$codename = hex($codename);

        for ($x=-1;$x<2;$x++) {
		my $tmp = ($fl + $x) + $codename;
                dbg(sprintf("TRY: x(%s) floor(%d) %lu %X\n", $x, ($fl+$x), $tmp, $tmp));
                return(1) if ($tmp == $auth);
        }

        return(undef);
}

# Filter out paths to hosts or disks that are down
sub anal_filter {
	return(@_) unless (-f "/opt/squid/redir_anal_flag"); # BOiNG!

	my (@paths) = @_;
	my $res;

	# Filter out downed boxes
	$analbq->execute();
	while ($res = $analbq->fetchrow()) {
		@paths = grep { !m!^http://$res! } @paths;
	}

	# Filter out downed disks
	$analdq->execute();
	while ($res = $analdq->fetchrow()) {
		@paths = grep { !m!/disk$res/! } @paths;
	}

	return(@paths);
}

sub dbg { print LOG ("@_") if ($debug); }