316 lines
11 KiB
Perl
316 lines
11 KiB
Perl
#!/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, <<DATA
|
|
Pragma: no-cache
|
|
Cache-Control: no-cache
|
|
Content-Language: en, ru
|
|
Content-type: text/html
|
|
|
|
<!DOCTYPE html>
|
|
<html lang="ru">
|
|
<head>
|
|
<meta charset="UTF-8" />
|
|
<style>
|
|
* {
|
|
margin: 10px;
|
|
text-align: center;
|
|
font-size: 14pt;
|
|
}
|
|
html, body {
|
|
background-color: #adc0fc;
|
|
}
|
|
</style>
|
|
<title>SlackPaste</title>
|
|
</head>
|
|
<body>
|
|
<img src="http://img.dafuq.ru/logo.png" />
|
|
|
|
<form method="post" action="/">
|
|
Shorten this link:<br />
|
|
<input type="text" size="30" maxlength="768" name="exs" style="font-size: 110%;" autofocus/></br />
|
|
<input type="submit" value="Submit" style="font-size: 85%;" />
|
|
<select name="etime" style="font-size: 85%; text-align:left;">
|
|
<option value="1" style="font-size: 85%; text-align:left;">1 Hour</option>
|
|
<option value="2" style="font-size: 85%; text-align:left;">12 Hours</option>
|
|
<option value="3" style="font-size: 85%; text-align:left;">1 day</option>
|
|
<option value="4" style="font-size: 85%; text-align:left;">1 week</option>
|
|
<option value="5" style="font-size: 85%; text-align:left;">1 Month</option>
|
|
<option value="6" style="font-size: 85%; text-align:left;">3 Months</option>
|
|
<option value="7" selected style="font-size: 85%; text-align:left;">6 Months</option>
|
|
<option value="8" style="font-size: 85%; text-align:left;">1 Year</option>
|
|
<option value="9" style="font-size: 85%; text-align:left;">2 Years</option>
|
|
<option value="10" style="font-size: 85%; text-align:left;">3 Years</option>
|
|
</select>
|
|
</form>
|
|
DATA
|
|
;
|
|
if((defined($str)) and ($str ne '')) { syswrite STDOUT, "<p>$str</p>"; }
|
|
syswrite STDOUT, <<DATA
|
|
</body>
|
|
</html>
|
|
|
|
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 для выбора предопределённых периодов хранения
|
|
|
|
|
|
<!DOCTYPE HTML>
|
|
<html>
|
|
<head>
|
|
<meta charset="utf-8">
|
|
<title>Exs URL Shortner.</title>
|
|
</head>
|
|
<body>
|
|
<form method="post" action="/s/">
|
|
<p style="text-align: center;"><b>URL Shortner</b></p>
|
|
<div style="text-align: center;"><input type="text" size="30" maxlength="256" name="exs" style="font-size:125%;"></div>
|
|
<p style="text-align: center;"><input type="submit" value="Shorten!"></p>
|
|
</form>
|
|
</body>
|
|
</html>
|