lnk.to

#!/usr/local/bin/perl require 5.6.0; #use warnings; #use strict; use DB_File; use URI::Escape qw(uri_unescape uri_escape); # LEGACY use CGI::Carp 'fatalsToBrowser'; use CGI qw/:standard/; use LWP::Simple; use Fcntl ':flock'; # import LOCK_* constants # LEGACY my $datafile = '/var/www/htdocs/lnk.to/data.db'; my $statsfile = '/var/www/htdocs/lnk.to/stats.db'; # v2 my $prefix = '/var/www/htdocs/lnk.to'; my $cache_top = "$prefix/cache_top"; my $cache_last = "$prefix/cache_last"; my $db = "$prefix/db"; system("rm /var/www/htdocs/lnk.to/db/bananas"); # LEGACY # DATA FILE FORMAT: # key -> uri_uncode(url)|ctime|uri_escape(title)|uri_escape(descr) # v2 # DATA FILE FORMAT # Tied hash -> db/key # %key = ( 'key', 'url', 'des', 'private', 'score', 'owner', 'log' ); # private and owner currently unimplemented. # Isolate key my $arg = $ENV{PATH_INFO} ? uri_unescape($ENV{PATH_INFO}) : ''; $arg =~ s|^\W+||; # Base case = redirect for key. if( length($arg) && $arg !~ /^_/ ) { # v2 if( stat("$db/$arg") ) { my %h; tie %h, "DB_File", "$db/$arg" or die "tie: $db/$arg: $!\n"; flock("$db/$arg",LOCK_EX); $h{'score'}++; $h{'log'} .= time() . " " . $ENV{'REMOTE_ADDR'} . " " . $ENV{'HTTP_REFERER'} . " " . $ENV{'HTTP_USER_AGENT'} . "\n"; print "Location: ", $h{'url'}, "\n\n"; flock("$db/$arg",LOCK_UN); untie %h; exit; } # LEGACY # my (%h,%s); # flock($datafile,LOCK_EX); # We'll use this lock as a mutex for # # statsfile as well. # tie %h, "DB_File", $datafile or die "Can not open $datafile: $!\n"; # tie %s, "DB_File", $statsfile or die "Can not open $statsfile: $!\n"; # LEGACY # my $throttle = $ENV{REMOTE_ADDR} . $arg; # if( $h{_throttle} eq $throttle ) { # print "Location: http://lnk.to/_throttle\n\n"; # exit; # } # If we keep hitting the same link with the same IP address, trigger _throttle. # LEGACY # my( $url, $crap ) = split(/\|/, $h{$arg}, 2); # if( $url ) { # $s{$arg}++; # print "Location: ", uri_unescape($url), "\n\n"; # $h{_throttle} = $throttle; # untie %h; # flock($datafile,LOCK_UN); # exit; # } # LEGACY # untie %h; # untie %s; # flock($datafile,LOCK_UN); } elsif( $arg eq '_rss' ) { use XML::RSS; my $rss = new XML::RSS; #(version=>'0.92'); $rss->channel( title => 'lnk.to', link => 'http://lnk.to/', description => 'Recently lnk.to URLs', webmaster => 'dannyman@toldme.com', ); open(LAST, $cache_last) or warn "open: $cache_last: $!\n"; while( ) { my($ts, $key, $des) = split(' ', $_, 3); $rss->add_item( title => $des, link => "http://lnk.to/$key", name => $key, ); } print "Content-type: text/xml\n\n"; print $rss->as_string; exit; } print "Content-Type: text/html\n\n"; print << "EndHTML"; lnk.to EndHTML my $query_string; if( $arg && $arg !~ /^_/ ) { print "

DANG!

\n"; print "

Sorry, compañero, but I don't remember a URL for "; print "http://lnk.to/$arg. Dang!

\n"; } elsif( $arg =~ /^_/ ) { $arg =~ s/\;(.*)//; $query_string = $1; } # If args were passed in query string, populate param() if( $query_string ) { $CGI::Q = new CGI($query_string) unless param(); } if( $arg eq '_throttle' ) { print "

WOAH!

\n"; print "

Woah there, bottle rocket, you just hit the same link twice. "; print "Let us end this madness now before you hurt yourself!

\n"; } print << "EndHTML";

lnk.to - Shorten that URL!

You know when your friend pastes a URL to you on IRC, and it's like seven lines long and a total pain to copy and paste in to your web browser properly? Well, now your friend can just visit lnk.to, paste the URL in here, and voilà!

EndHTML if( $arg eq "_add" ) { my $key = param('key'); my $url = param('url'); my $title; print "

Trying to lnk.to Something New ...

\n"; my %h; # LEGACY # flock($datafile,LOCK_EX); # tie %h, "DB_File", $datafile or die "Can not open $datafile: $!\n"; if( $url ) { if( $key !~ /^[A-Za-z0-9]+[A-Za-z0-9_]*$/ ) { if( $key ) { print "

WOAH! Sorry, but keys must consist of letters, numbers, and underscore characters, and can not start with an underscore. fr00fr00fr00

\n"; $key =~ s/^_*//; $key =~ s/\W//g; } } if( length($key) > 16 ) { print "

WOAH! Sorry, but $key is just too silly. Allow me to revise it for you.

\n"; if( stat("$db/mostly_harmless") ) { $key = 'harmless'; } else { $key = 'mostly_harmless'; } } my @ary = ('A' .. 'Z', 'a' .. 'z', 0 .. 9); $key = $ary[rand(@ary)] unless $key; # LEGACY # while( $h{$key} ) { # $key .= $ary[rand(@ary)]; # } # v2 while( stat("$db/$key") ) { $key .= $ary[rand(@ary)]; } tie %h, "DB_File", "$db/$key", or die "tie: $db/$key: $!\n"; flock("$db/$key",LOCK_EX); print "

Let us use $key for a key!

\n"; print "

Let's check this puppy out ... "; my $doc = get($url); if(! $doc ) { print "DANG: $!!

\n"; } else { $doc =~ /(.*?)<\/title>/is; $title = $1; $title =~ s/\n/ /gs; print "WHEE!</p>\n"; } # LEGACY # $h{$key} = uri_escape($url, "|") . "|" . time() . "|" . # uri_escape($title) . "|"; # v2 $h{'key'} = $key; $h{'url'} = $url; $h{'des'} = $title; $h{'score'}++; # LEGACY # if( $title ) { # my @last10 = split(/\|/, $h{_last10}); # if( @last10 >= 15 ) { shift @last10; } # Yeah, last10 -> 15, # # whatever ... # push @last10, $key; # $h{_last10} = join('|', @last10); # } open(LAST, ">>$cache_last") or warn "open: $cache_last: $!\n"; flock(LAST,LOCK_EX); print LAST time() . " $key $title\n"; flock(LAST,LOCK_UN); close(LAST); print "<p>Yay! <a href=\"http://lnk.to/$key\">http://lnk.to/$key</a> created!</p>\n"; print "<p>You can review information about your new link at <a href=\"http://lnk.to/_stat;key=$key\">http://lnk.to/_stat;key=$key</a>.</p>\n"; } else { print "<p>Hrmmm, I'm missing a URL from you. Sorry ...</p>\n"; } untie %h; # LEGACY # flock($datafile,LOCK_UN); # v2 flock("$db/$key",LOCK_UN); chmod 0666, "$db/$key"; } elsif( $arg eq '_stat' && param('key') ) { my $key = param('key'); tie %h, "DB_File", "$db/$key", or die "tie: $db/$key: $!\n"; flock("$db/$key",LOCK_EX); print<<__blob; <h3>Data for "$key"</h3> <p>http://lnk.to/<b>$h{'key'}</b>, <br>titled <b>$h{'des'}</b>, <br>links to <a href="$h{'url'}"><b>$h{'url'}</b></a>. <br>Current score is <b>$h{'score'}</b>.</p> <h3>Activity log for "$key"</h3> __blob print "<table>\n"; print "<tr><th>Time (GMT)</th><th>IP Address</th><th>Referring URL</th><th>User-Agent (Web Browser)</th></tr>\n"; foreach $line (split(/\n/, $h{'log'})) { print "<tr>\n"; my @a = split(/\ /, $line, 4); print "<td>" . gmtime($a[0]) . "</td>\n"; # timestamp print "<td>$a[1]</td>\n"; # IP print "<td><a href=\"$a[2]\">$a[2]</a></td>\n"; # Referer print "<td>$a[3]</td>\n"; # UA } print "</table>\n"; flock("$db/$key",LOCK_UN); untie %h; } print << "EndHTML"; <h3>lnk.to - Something New!</h3> <font size="-1"> <p align="center">NOTE: You want to type in a valid, fully-qualified URL like <code>http://www.frotz.net/</code>, and <b>not</b> simply <code>frotz.net</code>.</p> </font> <font size="-2"> <p align="center">ALSO NOTE: If you leave <code>http://lnk.to/</code> blank, lnk.to will generate a short URL for you at random.</p> </font> <font size="-3"> <p align="center">ALSO ALSO NOTE: If you enter a <code>http://lnk.to/</code> that already exists, lnk.to will generate a longer URL for you at random.</p> </font> <form action="/_add" method="POST"> <table> <tr> <td>http://lnk.to/<input type="text" name="key" size=8 /> <td>... links to: <input type="text" name="url" size=60 /> </tr> <tr><td align="center"> <input type="submit" value=">>> Add! <<<" /> </td><td align="center"> <input type="reset" value="*** Clear! ***" /> </td></tr> </table> </form> EndHTML # LEGACY # my (%h, %s); # flock($datafile,LOCK_EX); # tie %h, "DB_File", $datafile or die "Can not open $datafile: $!\n"; # tie %s, "DB_File", $statsfile or die "Can not open $statsfile: $!\n"; # LEGACY # print "<h3>lnk.to - Most Popular</h3>"; # my @top10 = sort { $s{$a} <=> $s{$b} } keys %s; # print "<table>\n"; # for( my $c = 1; $c < 16 && @top10; $c++ ) { # my $e = pop @top10; # print "<tr>\n"; # printf "<td>%d (%.2f)</td>\n", $c, $s{$e}; # print "<td><a href=\"http://lnk.to/$e\">http://lnk.to/$e</a></td>\n"; # my @a = split(/\|/, $h{$e}); # print "<td>" . uri_unescape($a[2]) . "</td>\n"; # print "</tr>\n"; # } # print "</table>\n"; # v2 print "<h3>lnk.to - Most Popular</h3>\n"; my $c; open(TOP, $cache_top) or warn "open: $cache_top: $!\n"; print "<table>\n"; while( <TOP> ) { if( $c < 20 ) { $c++; my($s, $k) = split(/\s/); print "<tr>\n"; printf "<td>%d (%.2f)</td>\n", $c, $s; print "<td><a href=\"http://lnk.to/$k\">http://lnk.to/$k</a></td>\n"; tie %h, "DB_File", "$db/$k", or warn "tie: $db/$k: $!\n"; flock("$db/$k",LOCK_EX); print "<td>", $h{'des'}, "</td>\n"; flock("$db/$k",LOCK_UN); untie %h; print "</tr>\n"; } } print "</table>\n"; close TOP; # LEGACY # print "<h3>lnk.to - Most Recent</h3>"; # my @last10 = split(/\|/, $h{_last10}); # print "<table>\n"; # while( my $e = pop @last10 ) { # print "<tr>\n"; # print "<td><a href=\"http://lnk.to/$e\">http://lnk.to/$e</a></td>\n"; # my @a = split(/\|/, $h{$e}); # print "<td>" . uri_unescape($a[2]) . "</td>\n"; # print "</tr>\n"; # } # print "</table>\n"; # v2 my @last; print "<h3>lnk.to - Most Recent</h3>\n"; open(LAST, $cache_last) or warn "open: $cache_last: $!\n"; while( <LAST> ) { push @last, $_; # if( @last > 15 ) { # shift @last; # } } close LAST; print "<table>\n"; while( my $str = pop @last ) { my($ts, $key, $des) = split(' ', $str, 3); print "<tr>\n"; print "<td><a href=\"http://lnk.to/$key\">http://lnk.to/$key</a></td>\n"; print "<td>$des</td>\n"; print "<td>(" . gmtime($ts) . " GST)</td>\n"; print "</tr>\n"; } print "</table>\n"; # LEGACY #untie %h; #untie %s; #flock($datafile,LOCK_UN); print << "EndHTML"; </body> </html> EndHTML exit 0;