#!/usr/bin/perl
# This isn't the cleanest code I've ever written...
use strict;
use warnings;
use POSIX 'strftime', 'ceil';
use TUWF ':html', 'html_escape';
my @syntax = sort map /([^\/]+)\.vim$/?$1:(),
glob("/usr/share/vim/{vim7?,vimfiles}/syntax/*.vim");
# IP-based throttling on invalid passcodes and paste codes.
$TUWF::OBJ->{throttle_interval} = 10;
$TUWF::OBJ->{throttle_burst} = 10;
TUWF::set(
logfile => $ENV{TUWF_LOG},
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();
sub init {
my $self = shift;
$self->dbh()->sqlite_busy_timeout(10000);
$self->dbExec(q(
CREATE TABLE IF NOT EXISTS pastes (
code TEXT PRIMARY KEY,
syntax TEXT NOT NULL DEFAULT 'nosyntax',
wrap INTEGER NOT NULL DEFAULT 0,
parse_urls INTEGER NOT NULL DEFAULT 0,
raw TEXT NOT NULL,
html TEXT,
date INTEGER NOT NULL,
lastvisit INTEGER NOT NULL,
passcode TEXT
)
));
$self->dbExec(q(
CREATE INDEX IF NOT EXISTS pastes_passcode ON pastes (passcode) WHERE passcode IS NOT NULL
));
$self->dbExec(q(
CREATE TABLE IF NOT EXISTS syntaxes AS
SELECT syntax, count(*) as cnt FROM pastes GROUP BY syntax
));
$self->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(
{ 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}};
my $code = $self->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');
my $p = $self->passcode('p', 'ps');
return if !defined $p;
require Encode;
my $dat = Encode::encode_utf8($self->reqPost('f')||'') || $self->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')
if !eval { $dat = Encode::decode_utf8($dat, 1); 1; };
return $self->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(
'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});
}
sub home {
my($self, $copy) = @_;
# upload form
if($self->reqMethod() ne 'POST') {
$self->htmlHeader('mypastes');
$self->htmlUploadForm($copy);
$self->htmlFooter;
return;
}
# handle upload
upload $self;
}
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};
my $th = $self->throttle_get();
return if $th == 1;
my($pl) = $self->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!');
}
my $cnt = ceil($self->dbRow('SELECT count(*) AS cnt FROM pastes WHERE passcode = ?', $p)->{cnt} / 100);
$self->htmlHeader('mypastes', 'newpaste');
Tr;
td class => 'ff', ' ';
td class => 'top';
b 'Listing all your pastes:';
table class => 'mypastelist';
for(@$pl) {
use utf8;
Tr;
td class => 'mpldate', strftime '%F %T', gmtime $_->{date};
td class => 'mplcode'; a href => "/$_->{code}", substr($_->{code}, 0, 5).(length $_->{code} > 5 ? '…':''); end;
td class => 'mplsyn', $_->{syntax};
td class => 'mplsize', sprintf '%.1fk', $_->{size}/1024;
td class => 'mplprev', $_->{preview};
end;
}
end;
if($f->{p} > 1 || $cnt > 1) {
form method => 'POST', action => '/mypastes', class => 'pagination';
input type => 'hidden', name => 'pc', value => $p;
b 'Page: ';
input type => 'submit', name => 'p', value => $_ for (1..($f->{p} - 1));
txt " $f->{p} ";
input type => 'submit', name => 'p', value => $_ for(($f->{p}+1)..$cnt);
end;
}
end;
end 'tr';
$self->htmlFooter;
}
sub raw {
my($self, $code) = @_;
my $r = $self->getpaste($code, 'raw');
return if !ref $r;
$self->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');
return if !ref($r);
my $cnt = ($r->{raw} =~ y/\n/\n/);
$cnt += 1 if $r->{raw} !~ /\n$/;
$self->htmlHeader(\$code, 'mypastes', 'newpaste');
Tr;
td class => 'numbers';
if(!$r->{wrap}) {
pre;
for (1..$cnt) {
a name => "r$_", href => "#r$_", $_;
lit "\n";
}
end;
}
end;
td class => 'top code';
pre $r->{wrap} ? (class => 'allowwrap') : ();
lit _get_html($r);
end;
end;
end 'tr';
$self->htmlFooter;
}
# utility functions
sub _escape_url {
my $str = shift;
my $r = '';
my $last = 0;
while($str =~ m{((?:https?|ftp)://[^ ><"\n\s]+[\d\w=/-])}g) {
$r .= sprintf '%s%2$s', html_escape(substr $str, $last, (pos($str)-length($1))-$last), html_escape($1);
$last = pos $str;
}
return $r.html_escape(substr $str, $last);
}
sub _get_html {
my $p = shift;
return $p->{html} if $p->{html};
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();
$r->Detach() if $r;
my $m = Text::VimColor->new(string => Encode::encode_utf8($p->{raw}), filetype => $p->{syntax})->marked();
$r->Attach() if $r;
my $html = '';
foreach (@$m) {
my $t = $e->(Encode::decode_utf8($_->[1]));
$html .= $_->[0] eq '' ? $t : qq|$t|;
}
return $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) = @_;
html lang => 'en';
head;
title 'Blicky.net pastebin';
Link rel => 'stylesheet', type => 'text/css', href => '/style.css';
meta name => 'robots', content => 'noindex, nofollow', undef;
end;
body;
div id => 'leftdiv', '';
div id => 'toplinks';
for(@links) {
txt ' ';
if(ref($_)) {
a href => '#', onclick => "return unpaste('/$$_')", 'unpaste';
txt ' ';
a href => "/$$_.txt", 'raw';
txt ' ';
a href => "/copy/$$_", 'copy';
} else {
/newpaste/ && a href => '/', 'new paste';
/mypastes/ && a href => '#', onclick => 'return mypastes()', 'my pastes';
}
}
end;
table;
Tr; td colspan => 2, class => 'header';
h1 'Blicky.net pastebin';
end; end;
}
sub htmlFooter {
end 'table';
script type => 'text/javascript', src => '/script.js', '';
end 'body';
end 'html';
}
sub htmlUploadForm {
my($self, $copy) = @_;
my $r = $copy
? $self->getpaste($copy, 'raw, wrap, parse_urls, syntax')
: { raw => '', wrap => 0, parse_urls => 1, syntax => 'nosyntax' };
return if !ref $r;
use utf8;
Tr;
td class => 'ff', '';
td class => 'top';
form enctype => 'multipart/form-data', 'accept-charset' => 'utf-8', method => 'post', action => '/';
fieldset;
legend '▾ Contents';
textarea name => 'f', id => 'f', $r->{raw};
br;
input type => 'submit', value => 'Submit', id => 'submit';
txt '-or- ';
input type => 'file', name => 'u', id => 'u';
i ' (UTF-8, max. ~1MiB)';
end;
fieldset;
legend '▾ Options';
a href => '#', id => 'formatsave', 'save as default';
input type => 'checkbox', class => 'check', id => 'w', name => 'w', value => 1, $r->{wrap} ? (checked => 'checked') : ();
label for => 'w', ' allow line wrapping';
br;
input type => 'checkbox', class => 'check', id => 'c', name => 'c', value => 1, $r->{parse_urls} ? (checked => 'checked') : ();
label for => 'c', ' make URLs clickable';
br;
i 'Syntax highlighting: ';
input type => 'text', name => 's', id => 's', size => 10, value => $r->{syntax};
i;
txt ' Popular: ';
b class => 'syntax';
for (@{$self->dbAll('SELECT syntax FROM syntaxes ORDER BY cnt DESC LIMIT 7')}) {
a href => '#', onclick => 'return setsyn(this)', $_->{syntax};
txt ' ';
}
end;
txt '| ';
a href => '#', onclick => 'return showall()', 'Show all »';
end 'i';
div id => 'syntax', style => 'display: none';
for (@syntax) {
a href => '#', onclick => 'return setsyn(this)', $_;
txt ' ';
}
end;
end 'fieldset';
fieldset;
legend '▾ Passcode';
label for => 'p', 'Passcode: ';
input type => 'password', name => 'p', id => 'p', size => 10;
input type => 'checkbox', class => 'check', id => 'ps', name => 'ps', value => 1;
label for => 'ps', ' save on my computer';
br;
i;
txt '(Optional, necessary for listing and/or removing your pastes.)';
br;
b 'Important:';
txt ' make sure your passcode is not something other people are likely to use.'
.' For example, use "nickname-asdf" instead of "asdf".';
end;
end 'fieldset';
end 'form';
fieldset;
legend '▾ Info';
ul;
li "Pastes don't expire.";
li 'All pastes are private, that is, nobody can find your paste unless they know the URL or the passcode.';
li;
txt 'If you absolutely need to have a paste removed from this site, and you lost your passcode, send a mail to ';
a href => 'mailto:ayo@blicky.net', 'ayo@blicky.net';
txt '.';
end;
li;
txt 'Want to paste stuff from the commandline? We have a ';
a href => '/bpaste.sh', 'script';
txt ' for that.';
end;
li 'Code highlighting is provided by vim.';
li;
txt 'This website is ';
a href => 'https://g.blicky.net/bpaste.git', 'open source';
txt '.';
end;
end;
end 'fieldset';
end 'td';
end 'tr';
}
# Function directly stolen from VNDB's VNDBUtil.pm
sub norm_ip {
my $ip = shift;
my $v4 = inet_pton AF_INET, $ip;
if($v4) {
$v4 =~ s/(..)(.)./$1 . chr(ord($2) & 254) . "\0"/se;
return inet_ntop AF_INET, $v4;
}
$ip = inet_pton AF_INET6, $ip;
return '::' if !$ip;
$ip =~ s/^(.{6}).+$/$1 . "\0"x10/se;
return inet_ntop AF_INET6, $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};
$th = $tm if !$th || $th < $tm;
return $self->msg('Throttled.')
if $th-$tm > $self->{throttle_burst}*$self->{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});
}
# fetches a paste and handles throttling and updates lastvisit column when necessary
sub getpaste {
my($self, $code, $col) = @_;
my $th = $self->throttle_get();
return if $th == 1;
my $r = $self->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.');
}
$self->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');
Tr;
td class => 'numbers', '';
td class => 'top';
br;
lit html_escape $msg;
if($back) {
br;
a href => 'javascript:history.go(-1)', 'Back to the form';
}
end;
end 'tr';
$self->htmlFooter;
return 1;
}
# fetch passcode and set cookie when requested
sub passcode {
my($self, $p, $ps) = @_;
my $f = $self->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');
return undef;
}
$self->resCookie(secret_passcode => $f->{$p}, path => '/', expires => time()+3*365*24*3600) if $f->{$p} && $f->{$ps};
return $f->{$p};
}
# Get a secure and uniform random number between 0 and $n (0 inclusive, $n exclusive, $n <= 256)
sub getrand {
my $n = shift;
state $R;
if(!$R) {
open $R, '<', '/dev/urandom' or die "Unable to open /dev/urandom\n";
}
my $i = 20;
while($i-- > 0) {
my $buf;
die "Unable to read from /dev/urandom" if sysread($R, $buf, 1) != 1;
my $c = unpack('C', $buf);
return $c % $n if $c < $n*floor(256/$n);
}
die "Unable to fetch random number\n";
}
# Paste codes are now 12 characters of [a-zA-Z0-9], which is around 71.5 bits
# in strength. This is already hard (but not entirely infeasable) to
# 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};
return $code;
}