#!/usr/bin/perl
###########################################
# Mike Schilli, 2003 (m@perlmeister.com)
###########################################
use warnings;
use strict;
use Log::Log4perl qw(:easy);
use Cache::FileCache;

my $DB_FILE     = "/tmp/shrinky.dat";
my $DB_MAX_SIZE = 10_000_000;
my $MAX_URL_LEN = 256;
my $REQS_PER_IP = 200;

Log::Log4perl->init(\ <<"EOT");
log4perl.logger = DEBUG, Rot
log4perl.appender.Rot=\\
  Log::Dispatch::FileRotate
log4perl.appender.Rot.filename=\\
  /tmp/shrink.log
log4perl.appender.Rot.layout=\\
  PatternLayout
log4perl.appender.Rot.layout.\\
ConversionPattern=%d %m%n
log4perl.appender.Rot.mode=append
log4perl.appender.Rot.size=1
log4perl.appender.Rot.max=1
EOT

use CGI qw(:all);
use CGI::Carp qw(fatalsToBrowser);
use DB_File;

tie my %URLS, 'DB_File', $DB_FILE, 
    O_RDWR|O_CREAT, 0755 or 
        LOGDIE "tie failed: $!";

    # First time initialization
$URLS{"next/"} ||= 1;

my $redir = "";

if(exists $ENV{PATH_INFO}) {
        # Redirect requested
    my $num = substr($ENV{PATH_INFO}, 1);
    $redir = $URLS{"by_shrink/$num"} if 
        $num ne "_" 
        and exists $URLS{"by_shrink/$num"};
}

if($redir) {
    print redirect($redir);
    goto END;
}

print header();

if(my $url = param('url')) {

    if(length $url > $MAX_URL_LEN) {
      print "Sorry, URL too long.\n";
      goto END;
    }

    my $surl;

    # Does it already exist?
    if(exists $URLS{"by_url/$url"}) {
      DEBUG "$url exists already";
      $surl = $URLS{"by_url/$url"};

    } else {
      if(-s $DB_FILE > $DB_MAX_SIZE) {
        DEBUG "DB File maxed out " . 
             (-s $DB_FILE) . " > $DB_FILE";
        print "Sorry, no more URLs.\n";
        goto END;
      }

      if(rate_limit($ENV{REMOTE_ADDR})) {
        print "Sorry, too many requests " .
              "from this IP\n";
        goto END;
      }

      # Register new URL
      my $n = base36($URLS{"next/"}++);
      INFO "$url: New shortcut: $n";
      $surl = url() . "/$n";
        $URLS{"by_shrink/$n"} = $url;
        $URLS{"by_url/$url"}  = $surl;
    }
    print a({href => $surl}, $surl);
  }

      # Accept user input
  print h1("Add a URL"), 
        start_form(), 
        textfield(-size    => 60, 
                  -name    => "url", 
                  -default => "http://"), 
        submit(), end_form();
    
END:

untie %URLS;

###########################################
sub base36 {
###########################################
    my ($num) = @_;

    use integer;

    my @chars  = ('0'..'9', 'a'..'z');
    my $result = "";

    for(my $b=@chars; $num; $num/=$b) {
        $result .= $chars[$num % $b];
    }

    return scalar reverse $result;
}

###########################################
sub rate_limit {
###########################################
    my ($ip) = @_;

    $ip = 'NO_IP' unless defined $ip;

    INFO "Request from IP $ip";

    my $cache = Cache::FileCache->new(
        { default_expires_in  => 3600*24,
          auto_purge_on_get   => 1,
        }
    );

    my $count = $cache->get($ip);

    if(defined $count and
       $count >= $REQS_PER_IP) {
        INFO "Rate-limiting IP $ip";
        return 1;
    }

    $cache->set($ip, ++$count);

    return 0;
}