#!/usr/bin/perl # vim: set ft=perl ts=8 sw=8 sts=8 ai et : use strict; use warnings "all"; use Fcntl; use BerkeleyDB; use CGI qw/:standard/; use CGI::Carp 'fatalsToBrowser'; $CGI::POST_MAX=1024 * 2; # max 2K posts $CGI::DISABLE_UPLOADS = 1; # no uploads my $datapath = '/var/www/s.dafuq.ru/data/'; my $db = $datapath . '/short.links.bdb'; my $tsdb = $datapath . '/timestamps.bdb'; my $expiresdb = $datapath . '/expires.bdb'; my $str = ''; my $url; my $hostname = $ENV{'HTTP_HOST'}; my $ts = time(); sub indexpage($); sub _initdb($); sub initdb(); sub http200($); sub http400($); sub http404($); sub http500($); sub genlinkname(); sub _urldecode($); my ($dbh, $tsdbh, $expdbh) = initdb(); if ((defined($ARGV[0])) and ($ARGV[0] ne 'index.html')){ # some web-servers add index page, quirk it # we got GET req. here, so let's redirect it. my $status = $dbh->db_get($ARGV[0], $url); if ($status == 0) { my $expires; $status = $expdbh->db_get($ARGV[0], $expires); if ($status != 0){ # expires time stamp missing $expires = $ts + (60*60*24*3*6); $expdbh->db_put($ARGV[0], $expires); } if($ts > $expires){ http404("Link expired. ts = $ts, expires = $expires"); } syswrite STDOUT, redirect($url); exit 0; } else { http404("Link not exist."); } }else{ # we got page/form request, or post link request if($ENV{'REQUEST_METHOD'} eq 'POST'){ # post link request # here we need to extract the link my $buf = _urldecode(param('exs')); if(($buf =~ /^http:/) or ($buf =~ /^https:/) or ($buf =~ /^ftp:/) or ($buf =~ /^xmpp:/) or ($buf =~ /^ipp:/) or ($buf =~ /^ldap:/) or ($buf =~ /^ldaps:/) or ($buf =~ /^irc:/) or ($buf =~ /^ircs:/) or ($buf =~ /^ssh:/) or ($buf =~ /^svn:/) or ($buf =~ /^git:/) or ($buf =~ /^hg:/) or ($buf =~ /^rtmp:/) or ($buf =~ /^rtsp:/) or ($buf =~ /^rtp:/) or ($buf =~ /^shoutcast:/) or ($buf =~ /^icecast:/) or ($buf =~ /^mailto:/) or ($buf =~ /^smb:/) or ($buf =~ /^magnet:/) or ($buf =~ /^ed2k:/) or ($buf =~ /^skype:/) or ($buf =~ /^dav:/) or ($buf =~ /^h323:/) or ($buf =~ /^rsync:/) or ($buf =~ /^sftp:/)){ }else{ http400('Invalid url.'); } my $name = genlinkname; $dbh->db_put($name, $buf); $tsdbh->db_put($name, $ts); my $ets = $ts + (60 * 60 * 24 * 30 * 6); my $etime = param('etime'); if (defined($etime)){ if ($etime == '1'){ $ets = $ts + (60*60); # 1 hour }elsif ($etime == '2'){ $ets = $ts + (60*60*12); # 12 hours }elsif ($etime == '3' ){ $ets = $ts + (60*60*24); # 1 day }elsif ($etime == '4' ){ $ets = $ts + (60*60*24*7); # 1 week }elsif ($etime == '5' ){ $ets = $ts + (60*60*24*30); # 1 month }elsif ($etime == '6' ){ $ets = $ts + (60*60*24*30*3); # 3 months }elsif ($etime == '7' ){ $ets = $ts + (60*60*24*30*6); # 6 months }elsif ($etime == '8' ){ $ets = $ts + (60*60*24*30*12); # 1 year }elsif ($etime == '9' ){ $ets = $ts + (60*60*24*30*24); # 2 years }elsif ($etime == '10' ){ $ets = $ts + (60*60*24*30*36); # 3 years } } $expdbh->db_put($name, $ets); # here we need to post form with extracted link or just string if (defined($ENV{'HTTP_USER_AGENT'})){ if (not($ENV{'HTTP_USER_AGENT'} =~ /^fetch libfetch/ or $ENV{'HTTP_USER_AGENT'} =~ /^curl\// or $ENV{'HTTP_USER_AGENT'} =~ /^Wget\// or $ENV{'HTTP_USER_AGENT'} =~ /^Axel / or $ENV{'HTTP_USER_AGENT'} =~ /^aria2\// or $ENV{'HTTP_USER_AGENT'} =~ /^Links \(/ or $ENV{'HTTP_USER_AGENT'} =~ /^Elinks( |\/)/ or $ENV{'HTTP_USER_AGENT'} =~ /^w3m\// or $ENV{'HTTP_USER_AGENT'} =~ /^Lynx( |\/)/ )){ indexpage("http://$hostname/$name"); } } http200("http://$hostname/$name"); }else{ # we got form request with GET/HEAD method, so print it indexpage(''); } } exit 0; sub indexpage($){ my $str = shift; syswrite STDOUT, < SlackPaste
Shorten this link:

DATA ; if((defined($str)) and ($str ne '')) { syswrite STDOUT, "

$str

"; } syswrite STDOUT, < DATA ; exit 0; } sub _initdb($){ my $db = shift; my $dbh = undef; unless (-f "$db"){ $dbh = new BerkeleyDB::Hash( -Filename => $db, -Flags => DB_CREATE ) or die "Error opening $db : $! $BerkeleyDB::Error\n"; }else{ $dbh = new BerkeleyDB::Hash( -Filename => $db, ) or die "Error opening $db : $! $BerkeleyDB::Error\n"; } return $dbh; } sub initdb(){ my @array; foreach($db, $tsdb, $expiresdb){ push @array, _initdb($_); } return @array; } sub http200($){ my $str = shift; syswrite STDOUT, header(-"Cache-Control"=>"no-store, no-cache, must-revalidate", -pragma => "no-cache", -type => "text/plain", -charset => "utf-8") . $str; exit 0; } sub http400($){ my $str = shift; syswrite STDOUT, "Status: 400 Bad Request Content-type: text/plain $str "; exit 0; } sub http404($){ my $str = shift; syswrite STDOUT, "Status: 404 Not Found Content-type: text/plain $str "; exit 0; } sub genlinkname(){ my $count = 0; my $name = ''; my $status = 1; # make collision possibility minimal :) do { last if($count > 1000); # it should'a be really big amount of links :) my $nlen = (int rand 6) + 3; for(my $i = 0; $i < $nlen; $i++){ $name .= ('a'..'z', 'A'..'Z')[int rand length(join('',('a'..'z', 'A'..'Z')))]; } $status = $dbh->db_get($name, undef); $count++; } unless ($status == 0); http400('Namespace exhausted.') if($status == 0); return $name; } sub _urldecode($){ my $string = shift; $string =~ s/\%([A-Fa-f0-9]{2})/pack('C', hex($1))/seg; return $string; } __END__ По сравнению с оргинальной версией сделано: Чистка кода, Перевод кода на CGI.pm, всё ровно в последствии надо будет извлекать несколько параметров из POST-а реализация мех-ма со сроком хранения ссылок реализация web-api для выбора предопределённых периодов хранения Exs URL Shortner.

URL Shortner