diff options
-rwxr-xr-x | index.cgi | 242 |
1 files changed, 107 insertions, 135 deletions
@@ -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(); |