#!/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 {
  return 0 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(0), '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<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->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;
}


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();