Listing 1: u - Save as Save Can

001 #!/usr/bin/perl
002 ###########################################
003 # Mike Schilli, 2003 (m@perlmeister.com)
004 ###########################################
005 use warnings;
006 use strict;
007 use Log::Log4perl qw(:easy);
008 use Cache::FileCache;
009
010 my $DB_FILE     = "/tmp/shrinky.dat";
011 my $DB_MAX_SIZE = 10_000_000;
012 my $MAX_URL_LEN = 256;
013 my $REQS_PER_IP = 200;
014
015 Log::Log4perl->init(\ <<"EOT");
016 log4perl.logger = DEBUG, Rot
017 log4perl.appender.Rot=\\
018   Log::Dispatch::FileRotate
019 log4perl.appender.Rot.filename=\\
020   /tmp/shrink.log
021 log4perl.appender.Rot.layout=\\
022   PatternLayout
023 log4perl.appender.Rot.layout.\\
024 ConversionPattern=%d %m%n
025 log4perl.appender.Rot.mode=append
026 log4perl.appender.Rot.size=1000000
027 log4perl.appender.Rot.max=1
028 EOT
029
030 use CGI qw(:all);
031 use CGI::Carp qw(fatalsToBrowser);
032 use DB_File;
033
034 tie my %URLS, 'DB_File', $DB_FILE,
035     O_RDWR|O_CREAT, 0755 or
036         LOGDIE "tie failed: $!";
037
038     # First time initialization
039 $URLS{"next/"} ||= 1;
040
041 my $redir = "";
042
043 if(exists $ENV{PATH_INFO}) {
044         # Redirect requested
045     my $num = substr($ENV{PATH_INFO}, 1);
046     $redir = $URLS{"by_shrink/$num"} if
047         $num ne "_"
048         and exists $URLS{"by_shrink/$num"};
049 }
050
051 if($redir) {
052     print redirect($redir);
053     goto END;
054 }
055
056 print header();
057
058 if(my $url = param('url')) {
059
060     if(length $url > $MAX_URL_LEN) {
061       print "Sorry, URL too long.\n";
062       goto END;
063     }
064
065     my $surl;
066
067     # Does it already exist?
068     if(exists $URLS{"by_url/$url"}) {
069       DEBUG "$url exists already";
070       $surl = $URLS{"by_url/$url"};
071
072     } else {
073       if(-s $DB_FILE > $DB_MAX_SIZE) {
074         DEBUG "DB File maxed out " .
075              (-s $DB_FILE) . " > $DB_FILE";
076         print "Sorry, no more URLs.\n";
077         goto END;
078       }
079
080       if(rate_limit($ENV{REMOTE_ADDR})) {
081         print "Sorry, too many requests " .
082               "from this IP\n";
083         goto END;
084       }
085
086       # Register new URL
087       my $n = base36($URLS{"next/"}++);
088       INFO "$url: New shortcut: $n";
089       $surl = url() . "/$n";
090         $URLS{"by_shrink/$n"} = $url;
091         $URLS{"by_url/$url"}  = $surl;
092     }
093     print a({href => $surl}, $surl);
094   }
095
096       # Accept user input
097   print h1("Add a URL"),
098         start_form(),
099         textfield(-size    => 60,
100                   -name    => "url",
101                   -default => "http://"),
102         submit(), end_form();
103
104 END:
105
106 untie %URLS;
107
108 ###########################################
109 sub base36 {
110 ###########################################
111     my ($num) = @_;
112
113     use integer;
114
115     my @chars  = ('0'..'9', 'a'..'z');
116     my $result = "";
117
118     for(my $b=@chars; $num; $num/=$b) {
119         $result .= $chars[$num % $b];
120     }
121
122     return scalar reverse $result;
123 }
124
125 ###########################################
126 sub rate_limit {
127 ###########################################
128     my ($ip) = @_;
129
130     $ip = 'NO_IP' unless defined $ip;
131
132     INFO "Request from IP $ip";
133
134     my $cache = Cache::FileCache->new(
135         { default_expires_in  => 3600*24,
136           auto_purge_on_get   => 1,
137         }
138     );
139
140     my $count = $cache->get($ip);
141
142     if(defined $count and
143        $count >= $REQS_PER_IP) {
144         INFO "Rate-limiting IP $ip";
145         return 1;
146     }
147
148     $cache->set($ip, ++$count);
149
150     return 0;
151 }