path: root/index.cgi

#!/usr/bin/perl


# SQL schema:
#
# CREATE TABLE pastes (
#   code char(5) PRIMARY KEY,
#   syntax varchar NOT NULL DEFAULT 'nosyntax',
#   wrap boolean NOT NULL DEFAULT false,
#   raw text NOT NULL,
#   html text,
#   date timestamp with time zone NOT NULL DEFAULT now(),
#   lastvisit timestamp with time zone NOT NULL DEFAULT now(),
#   parse_urls boolean NOT NULL DEFAULT false,
#   passcode varchar
# );

# Converting from older schemas:
# 2010-12-23:
#  ALTER TABLE pastes DROP COLUMN ip;

# This isn't the cleanest code I've ever written...

use strict;
use warnings;
use TUWF ':html', 'html_escape';


my @syntax = map /([^\/]+)\.vim$/?$1:(),
  glob("/usr/share/vim/vim7?/syntax/*.vim");


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::register(
  qr//                   => \&home,
  qr/mypastes/           => \&mypastes,
  qr/([a-z0-9]{5})\.txt/ => \&raw,
  qr/([a-z0-9]{5})/      => \&paste,
);
TUWF::run();



sub home {
  my $self = shift;

  # upload form
  if($self->reqMethod() ne 'POST') {
    $self->htmlHeader('mypastes');
    $self->htmlUploadForm;
    $self->htmlFooter;
    return;
  }

  # handle upload
  my @chars = ('0'..'9', 'a'..'z');
  my $code = join '', map $chars[rand @chars], 1..5;

  # create redirect response first, so that any Set-Cookie headers aren't forgotten
  # msg() calls resInit() anyway
  $self->resRedirect("/$code", 'post');

  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 $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, raw, html, parse_urls, passcode) VALUES(!l)',
    [ $code, $f->{s}, $f->{w}, $dat, $html, $f->{c}, $p || undef]
  );
}


sub mypastes {
  my $self = shift;
  my $p = $self->passcode('pc','psp');

  my $pl = $self->dbAll(q|
    SELECT code, to_char(date, 'YYYY-MM-DD HH24:MI:SS') AS date, syntax,
           substring(raw from 1 for 150) AS preview, length(raw) AS size
      FROM pastes
     WHERE passcode = ?
     ORDER BY date DESC|,
     $p
  );
  return $self->msg('No pastes with that passcode!') if !@$pl;

  $self->htmlHeader('mypastes', 'newpaste');
  Tr;
   td class => 'ff', ' ';
   td class => 'top';
    b 'Listing all your pastes:';
    table class => 'mypastelist';
     for(@$pl) {
       Tr;
        td class => 'mpldate', $_->{date};
        td class => 'mplcode'; a href => "/$_->{code}", $_->{code}; end;
        td class => 'mplsyn',  $_->{syntax};
        td class => 'mplsize', sprintf '%.1fk', $_->{size}/1024;
        td class => 'mplprev', $_->{preview};
       end;
     }
    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');
    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);
    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 $m = Text::VimColor->new(string => Encode::encode_utf8($p->{raw}), filetype => $p->{syntax})->marked();
  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';


sub htmlHeader {
  my($self, @links) = @_;
  html lang => 'en';
  head;
   title 'Blicky.net nopaste';
   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';
      } 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 nopaste';
    end; end;
}


sub htmlFooter {
    end 'table';
    script type => 'text/javascript', src => '/script.js', '';
   end 'body';
  end 'html';
}


sub htmlUploadForm {
  my $self = shift;
  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', '';
      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 '▾ Formatting';
      a href => '#', id => 'formatsave', 'save as default';
      input type => 'checkbox', class => 'check', id => 'w', name => 'w', value => 1;
      label for => 'w', ' allow line wrapping';
      br;
      input type => 'checkbox', class => 'check', id => 'c', name => 'c', value => 1, checked => 'checked';
      label for => 'c', ' make URLs clickable';
      br;
      i 'Syntax highlighting: ';
      input type => 'text', name => 's', id => 's', size => 10, value => 'nosyntax';
      i;
       txt ' Popular: ';
       b class => 'syntax';
        for (@{$self->dbAll('SELECT syntax FROM pastes GROUP BY syntax ORDER BY count(*) 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 '▾';
     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.pl', 'script';
       txt ' for that.';
      end;
      li 'Code highlighting is provided by vim.';
     end;
    end 'fieldset';

   end 'td';
  end 'tr';
}


# fetches a paste and updates lastvisit column when necessary
sub getpaste {
  my($self, $code, $col) = @_;
  my $r = $self->dbRow(q|
    SELECT !s, (lastvisit < (NOW()-'1 day'::interval)) AS needsupdate
      FROM pastes WHERE code = ?
    |, $col, $code
  );
  return $self->msg('No paste with that code.') if !keys %$r;
  $self->dbExec('UPDATE pastes SET lastvisit = NOW() WHERE code = ?', $code) if $r->{needsupdate};
  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};
}