#!/usr/bin/perl
###########################################################################
# show_referers.cgi:
#	List referers for a page, used as SSI or include
#
# Maintained by l.m.orchard <deus_x@pobox.com> http://www.decafbad.com
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either version 2
# of the License, or (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details, published at
# http://www.gnu.org/copyleft/gpl.html
###########################################################################

use strict;
use CGI;
use DBI;
use Fcntl;
use MD5;
use Data::Dumper qw(Dumper);
use URI::URL;

use vars qw($db_host $db_name $db_user $db_pass);

### Global config
my $HOME = "/www/www.decafbad.com";
my $cache_dir	  = "$HOME/data/services_cache";
my $max_referers   = 20;
my $link_label_len = 40;
require "$HOME/data/mysql_auth.pl"; # Sorry, you don't get MySQL details. :) 

### Initialize
my $q = new CGI();

### Get parameters from URL query
my %params;
$params{cache_age}	  = $q->param('cache_age') || 1800;
$params{uri}			= $q->param('uri') || $ENV{DOCUMENT_URI} || '/';
my $url = new URI::URL($params{uri}, "http://www.decafbad.com");
$params{uri} = $url->path();
$params{link_label_len} = $q->param('label_len') || 80;
$params{exclude}		= $q->param('exclude')   || 'decafbad.com';
$params{referers}	   = $q->param('referers')  || 20;
$params{count}             = $q->param('count') || undef;
$params{db_host}		= $db_host;
$params{db_name}		= $db_name;
$params{db_user}		= $db_user;
$params{db_pass}		= $db_pass;


### Formulate a cache file signature
my $cache_signature =
  join(':', "show_referers", $params{uri}, $params{count},
	   $params{link_label_len}, $params{exclude}, $params{referers});

#my $out = list_referers(\%params);
my $out = perform_with_cache(\%params, \&list_referers,
							 $cache_dir, $cache_signature);
print $q->header();
print $out;

exit(0);

###########################################################################

sub list_referers {
	my ($params) = @_;
	
	my $uri = $params->{uri};
	if ($uri eq '/index.shtml') {
		$uri = '/';
	}
	
	my $dsn = "DBI:mysql:database=$params->{db_name};host=$params->{db_host}";
	my $dbh = DBI->connect($dsn, $params->{db_user}, $params->{db_pass});

	my %ref_rec = ();
	my %ref_titles = ();

        my $select_sth = $dbh->prepare
	  (qq^
           SELECT site_path, ref_url, ref_title, hits, created 
           FROM referer_links
           WHERE site_path=?
	   ^);
	$select_sth->execute($uri);
	while (my $row = $select_sth->fetchrow_hashref()) {
		$ref_rec{$row->{ref_url}} = $row->{hits};
		$ref_titles{$row->{ref_url}} = $row->{ref_title};
	}
	$select_sth->finish();

	my @ref_list = sort { $ref_rec{$b} <=> $ref_rec{$a} }
	  grep { !/127.0.0.1/ } ### HACK HACK HACK Need a better way to
		grep { !/192.168/ } ### leave out non-reachable referers.
		  grep { !/\/system\/pages/ } ### (And move this to the db update script)
			keys %ref_rec;

	if (defined $params->{exclude}) {
		my $exclude = $params->{exclude};
		@ref_list = grep { !/$exclude/ } @ref_list;
	}

	if ($params->{count} eq '1') {
		return scalar(@ref_list);
	}
	
	my $out = "<ul>\n";
	my $ref_cnt = 0;
	foreach my $ref (@ref_list) {
		if (defined $params->{exclude}) {
			my $exclude = $params->{exclude};
			next if ($ref =~ /$exclude/);
		}
		last if ($ref_cnt++ > $params->{referers});
		
		my $ref_count = $ref_rec{$ref};

		my $short_ref = truncate_str(($ref_titles{$ref}) ? $ref_titles{$ref}:$ref, $params->{link_label_len});
		$out .= qq^\t<li class="referer_link">^.
		  qq^<a class="referer_link" href="$ref">$short_ref</a>^.
			qq^&nbsp;($ref_count)</li>\n^;
	}
	$out .= "</ul>\n";
	return $out;
}

sub truncate_str {
	my ($str, $len) = @_;
	if (length($str) > $len) {
		my $half_len = $len / 2;
		return substr($str,0,$half_len)."...".substr($str,0-$half_len);
	} else {
		return $str;
	}
}

sub perform_with_cache {
	my ($params, $sub_to_perform, $cache_dir, $cache_signature) = @_;
	
	my $cache_fn			 = "$cache_dir/".MD5->hexhash($cache_signature);
	my $cache_modtime		= (stat($cache_fn))[9];
	
	### If the cached file is too old, re-render
	my $out;
	if ( (time() - $cache_modtime) > $params->{cache_age} ) {
		$cache_modtime = time();
		$out = $sub_to_perform->($params);
		
		unlink($cache_fn);
		open(FOUT, ">$cache_fn");
		print FOUT $out;
		close(FOUT);
	}
	
	### If cache not too old, just use the cached rendering
	else {
		local $/ = undef;
		open(FIN, "$cache_fn");
		$out = <FIN>;
		close(FIN);
	}
	
	return $out;
}