#!/usr/bin/perl
use v5.10;
use strict;
use warnings;
use POSIX 'strftime', 'ceil', 'floor';
use Socket 'inet_pton', 'inet_ntop', 'AF_INET', 'AF_INET6';
use TUWF ':Html5', 'html_escape', 'mkclass';
my @syntax = sort map /([^\/]+)\.vim$/?$1:(),
glob("/usr/share/vim/{vim??,vimfiles}/syntax/*.vim");
# IP-based throttling on invalid passcodes and paste codes.
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(
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],
);
TUWF::hook before => sub {
tuwf->done if tuwf->{_TUWF}{http} && tuwf->resFile('.', tuwf->reqPath);
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',
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
)
));
tuwf->dbExec(q(
CREATE INDEX IF NOT EXISTS pastes_passcode ON pastes (passcode) WHERE passcode IS NOT NULL
));
tuwf->dbExec(q(
CREATE TABLE IF NOT EXISTS syntaxes AS
SELECT syntax, count(*) as cnt FROM pastes GROUP BY syntax
));
tuwf->dbExec(q(
CREATE TABLE IF NOT EXISTS throttle (
key TEXT PRIMARY KEY,
timeout INTEGER NOT NULL DEFAULT 0
)
));
return 1;
};
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 msg('Unknown syntax code', 'backform') if $f->{_err} && grep $_->[0] eq 's', @{$f->{_err}};
my $code = getcode();
# create redirect response first, so that any Set-Cookie headers set in
# passcode() aren't forgotten. msg() calls resInit() anyway
tuwf->resRedirect("/$code", 'post');
my $p = passcode('p', 'ps');
return if !defined $p;
require Encode;
my $dat = Encode::encode_utf8(tuwf->reqPost('f')||'') || tuwf->reqUploadRaw('u') || '';
$dat =~ s/\x0D\x0A?/\n/g;
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 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}});
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 = 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});
};
TUWF::get '/' => sub {
template(['mypastes'], \&html_upload_form);
};
TUWF::get qr{/copy/$code_re} => sub {
template(['mypastes'], sub { html_upload_form(tuwf->capture(0)) });
};
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 = throttle_get();
return if $th == 1;
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) {
throttle_update($th);
return msg('No pastes with that passcode!');
}
my $cnt = ceil(tuwf->dbRow('SELECT count(*) AS cnt FROM pastes WHERE passcode = ?', $p)->{cnt} / 100);
template(['mypastes', 'newpaste'], sub {
Tr sub {
Td class => 'ff', ' ';
Td class => 'top', sub {
B 'Listing all your pastes:';
Table class => 'mypastelist', sub {
for(@$pl) {
use utf8;
Tr sub {
Td class => 'mpldate', strftime '%F %T', gmtime $_->{date};
Td class => 'mplcode', sub {
A href => "/$_->{code}", substr($_->{code}, 0, 5).(length $_->{code} > 5 ? '…':'');
};
Td class => 'mplsyn', $_->{syntax};
Td class => 'mplsize', sprintf '%.1fk', $_->{size}/1024;
Td class => 'mplprev', $_->{preview};
};
}
};
if($f->{p} > 1 || $cnt > 1) {
Form method => 'POST', action => '/mypastes', class => 'pagination', sub {
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);
};
}
};
};
});
};
TUWF::get qr{/$code_re\.txt} => sub {
my $r = getpaste(tuwf->capture(1), 'raw');
return if !ref $r;
tuwf->resHeader('Content-Type' => 'text/plain; charset=UTF-8');
Lit $r->{raw};
};
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$/;
template([\$code, 'mypastes', 'newpaste'], sub {
Tr sub {
Td class => 'numbers', sub {
if(!$r->{wrap}) {
Pre sub {
for (1..$cnt) {
A name => "r$_", href => "#r$_", $_;
Lit "\n";
}
};
}
};
Td class => 'top code', sub {
Pre mkclass(allowwrap => $r->{wrap}), sub {
Lit get_html($r);
};
};
};
});
};
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 {
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->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;
}
sub template {
my($links, $content) = @_;
Html lang => 'en', sub {
Head sub {
Title 'Blicky.net pastebin';
Link rel => 'stylesheet', type => 'text/css', href => '/style.css';
Meta name => 'robots', content => 'noindex, nofollow', undef;
};
Body sub {
Div id => 'leftdiv', '';
Div id => 'toplinks', sub {
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';
}
}
};
Table sub {
Tr sub {
Td colspan => 2, class => 'header', sub {
H1 'Blicky.net pastebin';
};
};
$content->();
};
Script type => 'text/javascript', src => '/script.js', '';
};
};
}
sub html_upload_form {
my $copy = shift;
my $r = $copy
? getpaste($copy, 'raw, wrap, parse_urls, syntax')
: { raw => '', wrap => 0, parse_urls => 1, syntax => 'nosyntax' };
return if !ref $r;
use utf8;
Tr sub {
Td class => 'ff', '';
Td class => 'top', sub {
Form enctype => 'multipart/form-data', 'accept-charset' => 'utf-8', method => 'post', action => '/', sub {
Fieldset sub {
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)';
};
Fieldset sub {
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 sub {;
Txt ' Popular: ';
B class => 'syntax', sub {
for (@{ tuwf->dbAll('SELECT syntax FROM syntaxes ORDER BY cnt DESC LIMIT 7') }) {
A href => '#', onclick => 'return setsyn(this)', $_->{syntax};
Txt ' ';
}
};
Txt '| ';
A href => '#', onclick => 'return showall()', 'Show all »';
};
Div id => 'syntax', style => 'display: none', sub {
for (@syntax) {
A href => '#', onclick => 'return setsyn(this)', $_;
Txt ' ';
}
};
};
Fieldset sub {
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 sub {
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".';
};
};
};
Fieldset sub {
Legend '▾ Info';
Ul sub {
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 sub {
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 '.';
};
Li sub {
Txt 'Want to paste stuff from the commandline? We have a ';
A href => '/bpaste.sh', 'script';
Txt ' for that.';
};
Li 'Code highlighting is provided by vim.';
Li sub {
Txt 'This website is ';
A href => 'https://g.blicky.net/bpaste.git', 'open source';
Txt '.';
};
};
};
};
};
}
# 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 $tm = time;
my $th = tuwf->dbRow('SELECT timeout FROM throttle WHERE key = ?', norm_ip(tuwf->reqIP))->{timeout};
$th = $tm if !$th || $th < $tm;
return msg('Throttled.')
if $th-$tm > throttle_burst*throttle_interval;
return $th;
}
sub throttle_update {
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($code, $col) = @_;
my $th = throttle_get();
return if $th == 1;
my $r = tuwf->dbRow(q|
SELECT !s, lastvisit FROM pastes WHERE code = ?
|, $col, $code
);
if(!keys %$r) {
throttle_update($th);
return msg('No paste with that code.');
}
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($msg, $back) = @_;
tuwf->resInit;
template(['mypastes', 'newpaste'], sub {
Tr sub {
Td class => 'numbers', '';
Td class => 'top', sub {
Br;
Lit html_escape $msg;
if($back) {
Br;
A href => 'javascript:history.go(-1)', 'Back to the form';
}
};
};
});
return 1;
}
# fetch passcode and set cookie when requested
sub passcode {
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}) {
msg("Oops! I couldn't handle your passcode. It is either too long, or it contains characters I can not handle.", 'backform');
return undef;
}
tuwf->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 @chars = ('0'..'9', 'a'..'z', 'A'..'Z');
my $code = join '', map $chars[getrand(scalar @chars)], 1..12;
die "Generated duplicate code: $code.\n" if tuwf->dbRow('SELECT 1 AS exist FROM pastes WHERE code = ?', $code)->{exist};
return $code;
}
TUWF::run();