path: root/index.cgi

#!/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,
);

my $codematch = qr/([a-z0-9]{5}|[a-zA-Z0-9\.-]{32})/;
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 },
    { post => 'l', required => 0, default => 0 },
  );
  return $self->msg('Unknown syntax code', 'backform') if $f->{_err} && grep $_->[0] eq 's', @{$f->{_err}};

  my $code = $self->getcode(!!$f->{l});
  return if !$code;

  # 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<a href="%s">%2$s</a>', 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|<span class="syn$_->[0]">$t</span>|;
  }
  return $html;
}




# object methods

package TUWF::Object;

use TUWF ':html', 'html_escape';
use Socket 'inet_pton', 'inet_ntop', 'AF_INET', 'AF_INET6';


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;
      input type => 'checkbox', class => 'check', id => 'l', name => 'l', value => 1;
      label for => 'l', ' secure but ugly URL';
      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};
}


sub getcode {
  my($self, $secure) = @_;
  # The secure character set must be a power-of-two number of chars, otherwise
  # we'd introduce a bias in the random string generator below. 32 characters
  # in base64 correspond to 192 bits, which is quite secure.
  my @chars = $secure ? ('0'..'9', 'a'..'z', 'A'..'Z', '-', '.') : ('0'..'9', 'a'..'z');
  my $numchars = $secure ? 32 : 5;

  open my $R, '<', '/dev/urandom' or die "Unable to open /dev/urandom\n";

  my($i, $code) = (0);
  while($i < 10) {
    # Use one byte of random for each character. We're throwing away some
    # random data this way (256 possibilities when we only have 36 or 64), but
    # that's alright.
    my $r = sysread($R, $code, $numchars);
    die "Did not read enough random numbers (got $r, $!)\n" if $r != $numchars;
    $code = join '', map $chars[$_ % @chars], unpack 'C*', $code;

    # Weird characters at the start or end are annoying, skip these
    next if $code =~ /^[-.]/ || $code =~ /[-.]$/;

    last if !$self->dbRow('SELECT 1 AS exist FROM pastes WHERE code = ?', $code)->{exist};
    warn "Generated duplicate code: $code. Trying again...\n";
    $i++;
  }

  if($i == 10) {
    warn "!! No unused code found within 10 iterations!\n";
    $self->msg('Unable to allocate new code, please try again later.');
    return undef;
  }

  return $code;
}