summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rwxr-xr-xindex.cgi242
1 files changed, 107 insertions, 135 deletions
diff --git a/index.cgi b/index.cgi
index 993909f..102aaa4 100755
--- a/index.cgi
+++ b/index.cgi
@@ -1,19 +1,22 @@
#!/usr/bin/perl
-# This isn't the cleanest code I've ever written...
-
+use v5.10;
use strict;
use warnings;
-use POSIX 'strftime', 'ceil';
+use POSIX 'strftime', 'ceil', 'floor';
+use Socket 'inet_pton', 'inet_ntop', 'AF_INET', 'AF_INET6';
use TUWF ':html', 'html_escape';
my @syntax = sort map /([^\/]+)\.vim$/?$1:(),
- glob("/usr/share/vim/{vim7?,vimfiles}/syntax/*.vim");
+ glob("/usr/share/vim/{vim??,vimfiles}/syntax/*.vim");
# IP-based throttling on invalid passcodes and paste codes.
-$TUWF::OBJ->{throttle_interval} = 10;
-$TUWF::OBJ->{throttle_burst} = 10;
+sub throttle_interval () { 10 };
+sub throttle_burst () { 10 };
+
+# The first two matches are legacy paste codes, will not be generated anymore.
+my $code_re = qr/([a-z0-9]{5}|[a-zA-Z0-9\.-]{32}|[a-zA-Z0-9]{12})/;
TUWF::set(
@@ -21,25 +24,14 @@ TUWF::set(
max_post_body => 1024*1024, # 1MiB
# let DBI figure out the login details from the DBI_ environment variables
db_login => [undef, undef, undef],
- pre_request_handler => \&init,
);
-# The first two matches are legacy paste codes, will not be generated anymore.
-my $codematch = qr/([a-z0-9]{5}|[a-zA-Z0-9\.-]{32}|[a-zA-Z0-9]{12})/;
-TUWF::register(
- qr// => \&home,
- qr/mypastes/ => \&mypastes,
- qr/copy\/$codematch/ => \&home,
- qr/$codematch\.txt/ => \&raw,
- qr/$codematch/ => \&paste,
-);
-TUWF::run();
+TUWF::hook before => sub {
+ return 0 if tuwf->{_TUWF}{http} && tuwf->resFile('.', tuwf->reqPath);
-sub init {
- my $self = shift;
- $self->dbh()->sqlite_busy_timeout(10000);
- $self->dbExec(q(
+ tuwf->dbh->sqlite_busy_timeout(10000);
+ tuwf->dbExec(q(
CREATE TABLE IF NOT EXISTS pastes (
code TEXT PRIMARY KEY,
syntax TEXT NOT NULL DEFAULT 'nosyntax',
@@ -52,97 +44,92 @@ sub init {
passcode TEXT
)
));
- $self->dbExec(q(
+ tuwf->dbExec(q(
CREATE INDEX IF NOT EXISTS pastes_passcode ON pastes (passcode) WHERE passcode IS NOT NULL
));
- $self->dbExec(q(
+ tuwf->dbExec(q(
CREATE TABLE IF NOT EXISTS syntaxes AS
SELECT syntax, count(*) as cnt FROM pastes GROUP BY syntax
));
- $self->dbExec(q(
+ tuwf->dbExec(q(
CREATE TABLE IF NOT EXISTS throttle (
key TEXT PRIMARY KEY,
timeout INTEGER NOT NULL DEFAULT 0
)
));
return 1;
-}
+};
-sub upload {
- my $self = shift;
-
- my $f = $self->formValidate(
+TUWF::post '/' => sub {
+ my $f = tuwf->formValidate(
{ post => 's', required => 0, default => 'nosyntax', enum => \@syntax },
{ post => 'w', required => 0, default => 0 },
{ post => 'c', required => 0, default => 0 },
);
- return $self->msg('Unknown syntax code', 'backform') if $f->{_err} && grep $_->[0] eq 's', @{$f->{_err}};
+ return msg('Unknown syntax code', 'backform') if $f->{_err} && grep $_->[0] eq 's', @{$f->{_err}};
- my $code = $self->getcode();
+ my $code = getcode();
# create redirect response first, so that any Set-Cookie headers set in
- # ->passcode() aren't forgotten. msg() calls resInit() anyway
- $self->resRedirect("/$code", 'post');
+ # passcode() aren't forgotten. msg() calls resInit() anyway
+ tuwf->resRedirect("/$code", 'post');
- my $p = $self->passcode('p', 'ps');
+ my $p = passcode('p', 'ps');
return if !defined $p;
require Encode;
- my $dat = Encode::encode_utf8($self->reqPost('f')||'') || $self->reqUploadRaw('u') || '';
+ my $dat = Encode::encode_utf8(tuwf->reqPost('f')||'') || tuwf->reqUploadRaw('u') || '';
$dat =~ s/\x0D\x0A?/\n/g;
- return $self->msg("Only UTF-8 encoded data is allowed!\nMake sure you're not uploading a binary file.", 'backform')
+ return msg("Only UTF-8 encoded data is allowed!\nMake sure you're not uploading a binary file.", 'backform')
if !eval { $dat = Encode::decode_utf8($dat, 1); 1; };
- return $self->msg("You don't have much to paste, do you?", 'backform')
+ return msg("You don't have much to paste, do you?", 'backform')
if $dat =~ /^[ \n\s\t]*$/s && $f->{s} ne 'whitespace';
- my $html = $f->{s} eq 'nosyntax' ? undef : _get_html({ raw => $dat, syntax => $f->{s}, parse_urls => $f->{c}});
- $self->dbExec(
+ my $html = $f->{s} eq 'nosyntax' ? undef : get_html({ raw => $dat, syntax => $f->{s}, parse_urls => $f->{c}});
+ tuwf->dbExec(
'INSERT INTO pastes (code, syntax, wrap, parse_urls, passcode, raw, html, date, lastvisit) VALUES(!l)',
[ $code, $f->{s}, $f->{w}?1:0, $f->{c}?1:0, $p||undef, $dat, $html, time, time]
);
- my $cnt = $self->dbRow('SELECT cnt FROM syntaxes WHERE syntax = ?', [ $f->{s} ])->{cnt};
- $self->dbExec($cnt ? 'UPDATE syntaxes SET cnt = cnt+1 WHERE syntax = ?' : 'INSERT INTO syntaxes (syntax, cnt) VALUES (?, 1)', $f->{s});
-}
+ my $cnt = tuwf->dbRow('SELECT cnt FROM syntaxes WHERE syntax = ?', [ $f->{s} ])->{cnt};
+ tuwf->dbExec($cnt ? 'UPDATE syntaxes SET cnt = cnt+1 WHERE syntax = ?' : 'INSERT INTO syntaxes (syntax, cnt) VALUES (?, 1)', $f->{s});
+};
-sub home {
- my($self, $copy) = @_;
+TUWF::get '/' => sub {
+ htmlHeader('mypastes');
+ htmlUploadForm();
+ htmlFooter();
+};
- # upload form
- if($self->reqMethod() ne 'POST') {
- $self->htmlHeader('mypastes');
- $self->htmlUploadForm($copy);
- $self->htmlFooter;
- return;
- }
- # handle upload
- upload $self;
-}
+TUWF::get qr{/copy/$code_re} => sub {
+ htmlHeader('mypastes');
+ htmlUploadForm(tuwf->capture(0));
+ htmlFooter();
+};
-sub mypastes {
- my $self = shift;
- my $p = $self->passcode('pc','psp');
- my $f = $self->formValidate({ post => 'p', required => 0, template => 'uint', min => 1, max => 100, default => 1});
- return $self->msg('Invalid passcode or page number') if !$p || $f->{_err};
+TUWF::post '/mypastes' => sub {
+ my $p = passcode('pc','psp');
+ my $f = tuwf->formValidate({ post => 'p', required => 0, template => 'uint', min => 1, max => 100, default => 1});
+ return msg('Invalid passcode or page number') if !$p || $f->{_err};
- my $th = $self->throttle_get();
+ my $th = throttle_get();
return if $th == 1;
- my($pl) = $self->dbPage({page => $f->{p}, results => 100}, q|
+ my($pl) = tuwf->dbPage({page => $f->{p}, results => 100}, q|
SELECT code, date, syntax, substr(raw, 1, 150) AS preview, length(raw) AS size
FROM pastes WHERE passcode = ? ORDER BY date DESC|, $p
);
if(!@$pl) {
- $self->throttle_update($th);
- return $self->msg('No pastes with that passcode!');
+ throttle_update($th);
+ return msg('No pastes with that passcode!');
}
- my $cnt = ceil($self->dbRow('SELECT count(*) AS cnt FROM pastes WHERE passcode = ?', $p)->{cnt} / 100);
+ my $cnt = ceil(tuwf->dbRow('SELECT count(*) AS cnt FROM pastes WHERE passcode = ?', $p)->{cnt} / 100);
- $self->htmlHeader('mypastes', 'newpaste');
+ htmlHeader('mypastes', 'newpaste');
Tr;
td class => 'ff', ' ';
td class => 'top';
@@ -170,41 +157,27 @@ sub mypastes {
}
end;
end 'tr';
- $self->htmlFooter;
-}
+ htmlFooter();
+};
-sub raw {
- my($self, $code) = @_;
- my $r = $self->getpaste($code, 'raw');
+TUWF::get qr{/$code_re\.txt} => sub {
+ my $r = getpaste(tuwf->capture(0), 'raw');
return if !ref $r;
- $self->resHeader('Content-Type' => 'text/plain; charset=UTF-8');
+ tuwf->resHeader('Content-Type' => 'text/plain; charset=UTF-8');
lit $r->{raw};
-}
-
-
-sub paste {
- my($self, $code) = @_;
+};
- # unpaste
- if($self->reqMethod eq 'POST') {
- my $r = $self->getpaste($code, 'passcode, syntax');
- return if !ref($r);
- return $self->msg('Incorrect passcode!')
- if !$r->{passcode} || !$self->reqPost('pc') || $r->{passcode} ne $self->reqPost('pc');
- $self->dbExec('DELETE FROM pastes WHERE code = ?', $code);
- $self->dbExec('UPDATE syntaxes SET cnt = cnt-1 WHERE syntax = ?', $r->{syntax});
- return $self->msg("Unpasted!");
- }
- # view
- my $r = $self->getpaste($code, 'wrap, raw, html, parse_urls, syntax');
+TUWF::get qr{/$code_re} => sub {
+ my $code = tuwf->capture(0);
+ my $r = getpaste($code, 'wrap, raw, html, parse_urls, syntax');
return if !ref($r);
my $cnt = ($r->{raw} =~ y/\n/\n/);
$cnt += 1 if $r->{raw} !~ /\n$/;
- $self->htmlHeader(\$code, 'mypastes', 'newpaste');
+ htmlHeader(\$code, 'mypastes', 'newpaste');
Tr;
td class => 'numbers';
if(!$r->{wrap}) {
@@ -218,18 +191,30 @@ sub paste {
end;
td class => 'top code';
pre $r->{wrap} ? (class => 'allowwrap') : ();
- lit _get_html($r);
+ lit get_html($r);
end;
end;
end 'tr';
- $self->htmlFooter;
-}
+ htmlFooter();
+};
+
+
+TUWF::post qr{/$code_re} => sub {
+ my $code = tuwf->capture(0);
+ my $r = getpaste($code, 'passcode, syntax');
+ return if !ref($r);
+ return msg('Incorrect passcode!')
+ if !$r->{passcode} || !tuwf->reqPost('pc') || $r->{passcode} ne tuwf->reqPost('pc');
+ tuwf->dbExec('DELETE FROM pastes WHERE code = ?', $code);
+ tuwf->dbExec('UPDATE syntaxes SET cnt = cnt-1 WHERE syntax = ?', $r->{syntax});
+ return msg("Unpasted!");
+};
# utility functions
-sub _escape_url {
+sub escape_url {
my $str = shift;
my $r = '';
my $last = 0;
@@ -241,17 +226,17 @@ sub _escape_url {
}
-sub _get_html {
+sub get_html {
my $p = shift;
return $p->{html} if $p->{html};
- my $e = $p->{parse_urls} ? \&_escape_url : \&html_escape;
+ my $e = $p->{parse_urls} ? \&escape_url : \&html_escape;
return $e->($p->{raw}) if $p->{syntax} eq 'nosyntax';
$ENV{LANG} = 'en_US.UTF-8';
require Text::VimColor;
require Encode;
- my $r = $TUWF::OBJ->reqFCGI();
+ my $r = tuwf->reqFCGI;
$r->Detach() if $r;
my $m = Text::VimColor->new(string => Encode::encode_utf8($p->{raw}), filetype => $p->{syntax})->marked();
$r->Attach() if $r;
@@ -265,20 +250,8 @@ sub _get_html {
}
-
-
-# object methods
-
-package TUWF::Object;
-
-use TUWF ':html', 'html_escape';
-use POSIX 'floor';
-use Socket 'inet_pton', 'inet_ntop', 'AF_INET', 'AF_INET6';
-use feature 'state';
-
-
sub htmlHeader {
- my($self, @links) = @_;
+ my @links = @_;
html lang => 'en';
head;
title 'Blicky.net pastebin';
@@ -318,10 +291,10 @@ sub htmlFooter {
sub htmlUploadForm {
- my($self, $copy) = @_;
+ my $copy = shift;
my $r = $copy
- ? $self->getpaste($copy, 'raw, wrap, parse_urls, syntax')
+ ? getpaste($copy, 'raw, wrap, parse_urls, syntax')
: { raw => '', wrap => 0, parse_urls => 1, syntax => 'nosyntax' };
return if !ref $r;
@@ -355,7 +328,7 @@ sub htmlUploadForm {
i;
txt ' Popular: ';
b class => 'syntax';
- for (@{$self->dbAll('SELECT syntax FROM syntaxes ORDER BY cnt DESC LIMIT 7')}) {
+ for (@{ tuwf->dbAll('SELECT syntax FROM syntaxes ORDER BY cnt DESC LIMIT 7') }) {
a href => '#', onclick => 'return setsyn(this)', $_->{syntax};
txt ' ';
}
@@ -433,48 +406,46 @@ sub norm_ip {
sub throttle_get {
- my $self = shift;
-
my $tm = time;
- my $th = $self->dbRow('SELECT timeout FROM throttle WHERE key = ?', norm_ip($self->reqIP))->{timeout};
+ my $th = tuwf->dbRow('SELECT timeout FROM throttle WHERE key = ?', norm_ip(tuwf->reqIP))->{timeout};
$th = $tm if !$th || $th < $tm;
- return $self->msg('Throttled.')
- if $th-$tm > $self->{throttle_burst}*$self->{throttle_interval};
+ return msg('Throttled.')
+ if $th-$tm > throttle_burst*throttle_interval;
return $th;
}
sub throttle_update {
- my($self, $th) = @_;
- $self->dbExec('INSERT OR REPLACE INTO throttle (key, timeout) VALUES (?, ?)', norm_ip($self->reqIP), $th+$self->{throttle_interval});
+ my $th = shift;
+ tuwf->dbExec('INSERT OR REPLACE INTO throttle (key, timeout) VALUES (?, ?)', norm_ip(tuwf->reqIP), $th+throttle_interval);
}
# fetches a paste and handles throttling and updates lastvisit column when necessary
sub getpaste {
- my($self, $code, $col) = @_;
- my $th = $self->throttle_get();
+ my($code, $col) = @_;
+ my $th = throttle_get();
return if $th == 1;
- my $r = $self->dbRow(q|
+ my $r = tuwf->dbRow(q|
SELECT !s, lastvisit FROM pastes WHERE code = ?
|, $col, $code
);
if(!keys %$r) {
- $self->throttle_update($th);
- return $self->msg('No paste with that code.');
+ throttle_update($th);
+ return msg('No paste with that code.');
}
- $self->dbExec('UPDATE pastes SET lastvisit = ? WHERE code = ?', time(), $code) if $r->{lastvisit} < time()-24*3600;
+ tuwf->dbExec('UPDATE pastes SET lastvisit = ? WHERE code = ?', time(), $code) if $r->{lastvisit} < time()-24*3600;
return $r;
}
# generates a simple message as response
sub msg {
- my($self, $msg, $back) = @_;
- $self->resInit;
- $self->htmlHeader('mypastes', 'newpaste');
+ my($msg, $back) = @_;
+ tuwf->resInit;
+ htmlHeader('mypastes', 'newpaste');
Tr;
td class => 'numbers', '';
td class => 'top';
@@ -486,23 +457,23 @@ sub msg {
}
end;
end 'tr';
- $self->htmlFooter;
+ htmlFooter;
return 1;
}
# fetch passcode and set cookie when requested
sub passcode {
- my($self, $p, $ps) = @_;
- my $f = $self->formValidate(
+ my($p, $ps) = @_;
+ my $f = tuwf->formValidate(
{ param => $p, required => 0, default => '', maxlength => 64, regex => qr/^[a-zA-Z0-9-_\.]+$/ },
{ param => $ps, required => 0 },
);
if($f->{_err}) {
- $self->msg("Oops! I couldn't handle your passcode. It is either too long, or it contains characters I can not handle.", 'backform');
+ msg("Oops! I couldn't handle your passcode. It is either too long, or it contains characters I can not handle.", 'backform');
return undef;
}
- $self->resCookie(secret_passcode => $f->{$p}, path => '/', expires => time()+3*365*24*3600) if $f->{$p} && $f->{$ps};
+ tuwf->resCookie(secret_passcode => $f->{$p}, path => '/', expires => time()+3*365*24*3600) if $f->{$p} && $f->{$ps};
return $f->{$p};
}
@@ -530,10 +501,11 @@ sub getrand {
# brute-force at high speeds, but is completely infeasable to guess with the
# throttle of 1 guess per 10 seconds in place.
sub getcode {
- my $self = shift;
my @chars = ('0'..'9', 'a'..'z', 'A'..'Z');
my $code = join '', map $chars[getrand(scalar @chars)], 1..12;
- die "Generated duplicate code: $code.\n" if $self->dbRow('SELECT 1 AS exist FROM pastes WHERE code = ?', $code)->{exist};
+ die "Generated duplicate code: $code.\n" if tuwf->dbRow('SELECT 1 AS exist FROM pastes WHERE code = ?', $code)->{exist};
return $code;
}
+
+TUWF::run();