diff --git a/app-old.pl b/app-old.pl new file mode 100755 index 0000000..7d120ed --- /dev/null +++ b/app-old.pl @@ -0,0 +1,272 @@ +#!/usr/bin/env perl + +use strict; +use warnings; +use v5.22; +no warnings "experimental::postderef"; +use feature "postderef", "postderef_qq"; + +use FindBin qw($Bin); +use lib "$Bin/lib"; +use Data::Dumper; +use DBI; +use Encode qw/decode/; + +use Mojolicious::Lite; +use Mojolicious::Plugin::TtRenderer; +use POE::Filter::Reference; +use App::Config; +use App::Memcached; +use Eval::Perlbot; +use IRC::Perlbot; +use DateTime; +use App::Spamfilter; + +plugin 'tt_renderer' => { + template_options => { + PRE_CHOMP => 1, + POST_CHOMP => 1, + TRIM => 1, + }, +}; + +app->renderer->default_handler( 'tt' ); + +if ($cfg->{features}{blogspam}) { + plugin 'BlogSpam' => ($cfg->{blogspam}->%*); +} + +my $dbh = DBI->connect("dbi:SQLite:dbname=pastes.db", "", "", {RaiseError => 1}); +$dbh->{sqlite_unicode} = 1; +# hardcode some channels first + +sub insert_pastebin { + my ($paste, $who, $what, $where, $expire, $lang) = @_; + + $expire = undef if !$expire; # make sure it's null if it's empty + + $dbh->do("INSERT INTO posts (paste, who, 'where', what, 'when', 'expiration', 'language') VALUES (?, ?, ?, ?, ?, ?, ?)", {}, $paste, $who, $where, $what, time(), $expire, $lang); + my $id = $dbh->last_insert_id('', '', 'posts', 'id'); + + # TODO this needs to retry when it fails. + my @chars = ('a'..'z', 1..9); + my $slug = join '', map {$chars[rand() *@chars]} 1..6; + $dbh->do("INSERT INTO slugs (post_id, slug) VAlUES (?, ?)", {}, $id, $slug); + + return $slug; +} + +get '/' => sub { + my $c = shift; + $c->stash({pastedata => q{}, channels => $cfg->{announce}{channels}, page_tmpl => 'editor.html'}); + $c->render("page"); +}; +get '/pastebin' => sub {$_[0]->redirect_to('/')}; +get '/paste' => sub {$_[0]->redirect_to('/')}; + + +post '/paste' => sub { + my $c = shift; + + my @args = map {($c->param($_))} qw/paste name desc chan expire language/; + + my $id = insert_pastebin(@args); + my ($code, $who, $desc, $channel) = @args; + + # TODO select which one based on config +# TODO make this use the config, or http params for the url + + if (my $type = App::Spamfilter::is_spam($c, $who, $desc, $code)) { + warn "I thought this was spam! $type"; + } else { + IRC::Perlbot::announce($c->param('chan'), $c->param('name'), substr($c->param('desc'), 0, 40), "https://perlbot.pl/pastebin/$id"); + } + + $c->redirect_to('/pastebin/'.$id); + #$c->render(text => "post accepted! $id"); +}; + +get '/edit/:pasteid' => sub { + my $c = shift; + my $pasteid = $c->param('pasteid'); + + my $row = $dbh->selectrow_hashref("SELECT * FROM posts WHERE id = ? LIMIT 1", {}, $pasteid); + + if ($row->{when}) { + $c->stash({pastedata => $row->{paste}, channels =>$cfg->{announce}{channels}}); + $c->stash({page_tmpl => 'editor.html'}); + + $c->render('page'); + } else { +# 404 + return $c->reply->not_found; + } +}; + +sub get_paste { + my $pasteid = shift; + my $row = $dbh->selectrow_hashref(q{ + SELECT p.* + FROM posts p + LEFT JOIN slugs s ON p.id = s.post_id + WHERE p.id = ? OR s.slug = ? + ORDER BY s.slug DESC + LIMIT 1 + }, {}, $pasteid, $pasteid); + + my $when = delete $row->{when}; + + if ($when) { + my $whendt = DateTime->from_epoch(epoch => $when); + + if (!$row->{expiration} || $whendt->clone()->add(hours => $row->{expiration}) >= DateTime->now()) { + $row->{when} = $whendt->iso8601; + return $row; + } else { + return undef; + } + } else { + return undef; + } +} + +get '/raw/:pasteid' => sub { + my $c = shift; + my $pasteid = $c->param('pasteid'); + + my $row = get_paste($pasteid); + + + if ($row) { + $c->render(text => $row->{paste}, format => "txt"); + } else { +# 404 + return $c->reply->not_found; + } + +}; +get '/pastebin/:pasteid' => sub { + my $c = shift; + my $pasteid = $c->param('pasteid'); + + my $row = get_paste($pasteid); + + if ($row) { + $c->stash($row); + $c->stash({page_tmpl => 'viewer.html'}); + $c->stash({eval => get_eval($pasteid, $row->{paste}, $row->{lang})}); + $c->stash({paste_id => $pasteid}); + + $c->render('page'); + } else { +# 404 + return $c->reply->not_found; + } + +}; + +post '/eval' => sub { + my ($c) = @_; + my $data = $c->req->body_params; + + my $code = $data->param('code') // ''; + + my $output = get_eval(undef, $code); + + $c->render(json => {evalout => $output}); +}; + +get '/robots.txt' => sub { + my ($c) = @_; + + $c->render(text => qq{User-agent: * +Disallow: /}); +}; + +get '/api/v1/paste/:pasteid' => sub { + my $c = shift; + my $pasteid = $c->param('pasteid'); + + my $row = get_paste($pasteid); + + if ($row) { + my $data = { + paste => $row->{paste}, + when => $row->{when}, + username => $row->{who}, + description => $row->{desc}, + language => $row->{language}, + output => get_eval($pasteid, $row->{paste}) + }; + + $c->render(json => $data); + } else { +# 404 + return $c->reply->not_found; + } +}; + +post '/api/v1/paste' => sub { + my $c = shift; + + # TODO rate limiting + + my @args = map {($c->param($_))} qw/paste username description channel expire language/; + + my $id = insert_pastebin(@args); + my ($code, $who, $desc, $channel) = @args; + + # TODO select which one based on config + # TODO make this use the config, or http params for the url + + if (my $type = App::Spamfilter::is_spam($c, $who, $desc, $code)) { + warn "I thought this was spam! $type"; + } else { + if ($channel) { # TODO config for allowing announcements + IRC::Perlbot::announce($channel, $who, substr($desc, 0, 40), "https://perlbot.pl/pastebin/$id"); + } + } + + $c->render(json => { + url => "https://perlbot.pl/pastebin/$id", # TODO base url in config + id => $id, + }); + #$c->render(text => "post accepted! $id"); +}; + +get '/api/v1/languages' => sub { + my $c=shift; + + $c->render(json => {languages => [ + {name => "perl", description => "Perl (blead/git)"}, + {name => "perl4", description => "Perl 4.0.36"}, + {name => "perl5.5", description => "Perl 5.5"}, + {name => "perl5.6", description => "Perl 5.6"}, + {name => "perl5.8", description => "Perl 5.8"}, + {name => "perl5.10", description => "Perl 5.10"}, + {name => "perl5.12", description => "Perl 5.12"}, + {name => "perl5.14", description => "Perl 5.14"}, + {name => "perl5.16", description => "Perl 5.16"}, + {name => "perl5.18", description => "Perl 5.18"}, + {name => "perl5.20", description => "Perl 5.20"}, + {name => "perl5.22", description => "Perl 5.22"}, + {name => "perl5.24", description => "Perl 5.24"}, + {name => "text", description => "Plain text"}, + ]}); +}; + +get '/api/v1/channels' => sub { + my $c=shift; + + $c->render(json => {channels => [ + {name => "localhost:perlbot:#perl", description => "Freenode #perl"}, + {name => "localhost:perlbot:#perlbot", description => "Freenode #perlbot"}, + {name => "localhost:perlbot:#perlcafe", description => "Freenode #perlcafe"}, + {name => "localhost:perlbot:#buutbot", description => "Freenode #buubot"}, + {name => "localhost:perlbot:##botparadise", description => "Freenode ##botparadise"}, + {name => "localhost:perlbot-magnet:#perl", description => "irc.perl.net #perl"}, + ]}); +}; + +app->start; + diff --git a/app.pl b/app.pl index 24ef4b8..57193e5 100755 --- a/app.pl +++ b/app.pl @@ -2,271 +2,9 @@ use strict; use warnings; -use v5.22; -no warnings "experimental::postderef"; -use feature "postderef", "postderef_qq"; -use FindBin qw($Bin); -use lib "$Bin/lib"; -use Data::Dumper; -use DBI; -use Encode qw/decode/; - -use Mojolicious::Lite; -use Mojolicious::Plugin::TtRenderer; -use POE::Filter::Reference; -use App::Config; -use App::Memcached; -use Eval::Perlbot; -use IRC::Perlbot; -use DateTime; -use App::Spamfilter; - -plugin 'tt_renderer' => { - template_options => { - PRE_CHOMP => 1, - POST_CHOMP => 1, - TRIM => 1, - }, -}; - -app->renderer->default_handler( 'tt' ); - -if ($cfg->{features}{blogspam}) { - plugin 'BlogSpam' => ($cfg->{blogspam}->%*); -} - -my $dbh = DBI->connect("dbi:SQLite:dbname=pastes.db", "", "", {RaiseError => 1}); -$dbh->{sqlite_unicode} = 1; -# hardcode some channels first - -sub insert_pastebin { - my ($paste, $who, $what, $where, $expire, $lang) = @_; - - $expire = undef if !$expire; # make sure it's null if it's empty - - $dbh->do("INSERT INTO posts (paste, who, 'where', what, 'when', 'expiration', 'language') VALUES (?, ?, ?, ?, ?, ?, ?)", {}, $paste, $who, $where, $what, time(), $expire, $lang); - my $id = $dbh->last_insert_id('', '', 'posts', 'id'); - - # TODO this needs to retry when it fails. - my @chars = ('a'..'z', 1..9); - my $slug = join '', map {$chars[rand() *@chars]} 1..6; - $dbh->do("INSERT INTO slugs (post_id, slug) VAlUES (?, ?)", {}, $id, $slug); - - return $slug; -} - -get '/' => sub { - my $c = shift; - $c->stash({pastedata => q{}, channels => $cfg->{announce}{channels}, page_tmpl => 'editor.html'}); - $c->render("page"); -}; -get '/pastebin' => sub {$_[0]->redirect_to('/')}; -get '/paste' => sub {$_[0]->redirect_to('/')}; - - -post '/paste' => sub { - my $c = shift; - - my @args = map {($c->param($_))} qw/paste name desc chan expire language/; - - my $id = insert_pastebin(@args); - my ($code, $who, $desc, $channel) = @args; - - # TODO select which one based on config -# TODO make this use the config, or http params for the url - - if (my $type = App::Spamfilter::is_spam($c, $who, $desc, $code)) { - warn "I thought this was spam! $type"; - } else { - IRC::Perlbot::announce($c->param('chan'), $c->param('name'), substr($c->param('desc'), 0, 40), "https://perlbot.pl/pastebin/$id"); - } - - $c->redirect_to('/pastebin/'.$id); - #$c->render(text => "post accepted! $id"); -}; - -get '/edit/:pasteid' => sub { - my $c = shift; - my $pasteid = $c->param('pasteid'); - - my $row = $dbh->selectrow_hashref("SELECT * FROM posts WHERE id = ? LIMIT 1", {}, $pasteid); - - if ($row->{when}) { - $c->stash({pastedata => $row->{paste}, channels =>$cfg->{announce}{channels}}); - $c->stash({page_tmpl => 'editor.html'}); - - $c->render('page'); - } else { -# 404 - return $c->reply->not_found; - } -}; - -sub get_paste { - my $pasteid = shift; - my $row = $dbh->selectrow_hashref(q{ - SELECT p.* - FROM posts p - LEFT JOIN slugs s ON p.id = s.post_id - WHERE p.id = ? OR s.slug = ? - ORDER BY s.slug DESC - LIMIT 1 - }, {}, $pasteid, $pasteid); - - my $when = delete $row->{when}; - - if ($when) { - my $whendt = DateTime->from_epoch(epoch => $when); - - if (!$row->{expiration} || $whendt->clone()->add(hours => $row->{expiration}) >= DateTime->now()) { - $row->{when} = $whendt->iso8601; - return $row; - } else { - return undef; - } - } else { - return undef; - } -} - -get '/raw/:pasteid' => sub { - my $c = shift; - my $pasteid = $c->param('pasteid'); - - my $row = get_paste($pasteid); - - - if ($row) { - $c->render(text => $row->{paste}, format => "txt"); - } else { -# 404 - return $c->reply->not_found; - } - -}; -get '/pastebin/:pasteid' => sub { - my $c = shift; - my $pasteid = $c->param('pasteid'); - - my $row = get_paste($pasteid); - - if ($row) { - $c->stash($row); - $c->stash({page_tmpl => 'viewer.html'}); - $c->stash({eval => get_eval($pasteid, $row->{paste})}); - $c->stash({paste_id => $pasteid}); - - $c->render('page'); - } else { -# 404 - return $c->reply->not_found; - } - -}; - -post '/eval' => sub { - my ($c) = @_; - my $data = $c->req->body_params; - - my $code = $data->param('code') // ''; - - my $output = get_eval(undef, $code); - - $c->render(json => {evalout => $output}); -}; - -get '/robots.txt' => sub { - my ($c) = @_; - - $c->render(text => qq{User-agent: * -Disallow: /}); -}; - -get '/api/v1/paste/:pasteid' => sub { - my $c = shift; - my $pasteid = $c->param('pasteid'); - - my $row = get_paste($pasteid); - - if ($row) { - my $data = { - paste => $row->{paste}, - when => $row->{when}, - username => $row->{who}, - description => $row->{desc}, - language => $row->{language}, - output => get_eval($pasteid, $row->{paste}) - }; - - $c->render(json => $data); - } else { -# 404 - return $c->reply->not_found; - } -}; - -post '/api/v1/paste' => sub { - my $c = shift; - - # TODO rate limiting - - my @args = map {($c->param($_))} qw/paste username description channel expire language/; - - my $id = insert_pastebin(@args); - my ($code, $who, $desc, $channel) = @args; - - # TODO select which one based on config - # TODO make this use the config, or http params for the url - - if (my $type = App::Spamfilter::is_spam($c, $who, $desc, $code)) { - warn "I thought this was spam! $type"; - } else { - if ($channel) { # TODO config for allowing announcements - IRC::Perlbot::announce($channel, $who, substr($desc, 0, 40), "https://perlbot.pl/pastebin/$id"); - } - } - - $c->render(json => { - url => "https://perlbot.pl/pastebin/$id", # TODO base url in config - id => $id, - }); - #$c->render(text => "post accepted! $id"); -}; - -get '/api/v1/languages' => sub { - my $c=shift; - - $c->render(json => {languages => [ - {name => "perl", description => "Perl (blead/git)"}, - {name => "perl4", description => "Perl 4.0.36"}, - {name => "perl5.5", description => "Perl 5.5"}, - {name => "perl5.6", description => "Perl 5.6"}, - {name => "perl5.8", description => "Perl 5.8"}, - {name => "perl5.10", description => "Perl 5.10"}, - {name => "perl5.12", description => "Perl 5.12"}, - {name => "perl5.14", description => "Perl 5.14"}, - {name => "perl5.16", description => "Perl 5.16"}, - {name => "perl5.18", description => "Perl 5.18"}, - {name => "perl5.20", description => "Perl 5.20"}, - {name => "perl5.22", description => "Perl 5.22"}, - {name => "perl5.24", description => "Perl 5.24"}, - {name => "text", description => "Plain text"}, - ]}); -}; - -get '/api/v1/channels' => sub { - my $c=shift; - - $c->render(json => {channels => [ - {name => "localhost:perlbot:#perl", description => "Freenode #perl"}, - {name => "localhost:perlbot:#perlbot", description => "Freenode #perlbot"}, - {name => "localhost:perlbot:#perlcafe", description => "Freenode #perlcafe"}, - {name => "localhost:perlbot:#buutbot", description => "Freenode #buubot"}, - {name => "localhost:perlbot:##botparadise", description => "Freenode ##botparadise"}, - {name => "localhost:perlbot-magnet:#perl", description => "irc.perl.net #perl"}, - ]}); -}; - -app->start; +use lib 'lib'; +use Mojolicious::Commands; +# Start command line interface for application +Mojolicious::Commands->start_app('App'); diff --git a/lib/App.pm b/lib/App.pm new file mode 100644 index 0000000..c036b85 --- /dev/null +++ b/lib/App.pm @@ -0,0 +1,41 @@ +package App; + +use strict; +use warnings; +use v5.22; + +use Mojo::Base 'Mojolicious'; + +use Mojolicious::Plugin::TtRenderer; +use App::Config; +use App::Controller::Paste; + +sub startup { + my $self = shift; + + $self->plugin('tt_renderer' => { + template_options => { + PRE_CHOMP => 1, + POST_CHOMP => 1, + TRIM => 1, + }, + }); + + $self->renderer->default_handler( 'tt' ); + + if ($cfg->{features}{blogspam}) { + $self->plugin('BlogSpam' => ($cfg->{blogspam}->%*)); + } + + $self->routes(); +} + +sub routes { + my $self = shift; + + App::Controller::Paste->routes($self->routes); + App::Controller::Eval->routes($self->routes); + App::Controller::API::v1->routes($self->routes); +} + +1; diff --git a/lib/App/Config.pm b/lib/App/Config.pm index 0f700a6..86be0f9 100644 --- a/lib/App/Config.pm +++ b/lib/App/Config.pm @@ -21,4 +21,10 @@ our $cfg = do { $data; }; +sub get_config { + my $key = shift; + + return $cfg->{$key}; +} + 1; diff --git a/lib/App/Controller/Apiv1.pm b/lib/App/Controller/Apiv1.pm new file mode 100644 index 0000000..336aa09 --- /dev/null +++ b/lib/App/Controller/Apiv1.pm @@ -0,0 +1,111 @@ +package App::Controller::Apiv1; + +use strict; +use warnings; + +use Mojo::Base 'Mojolicious::Controller'; + +sub routes { + my ($class, $_r) = @_; + + my $route = sub { + my ($method, $route, $action) = @_; + $r->$method($route)->to(controller => 'apiv1', action => $action); + }; + + # TODO make this use an automatic base for the version on the endpoints + + $route->(get => '/api/v1/paste/:pasteid' => 'api_get_paste'); + $route->(post => '/api/v1/paste' => 'api_post_paste'); + $route->(get => '/api/v1/languages' => 'api_get_languages'); + $route->(get => '/api/v1/channels' => 'api_get_channels'); +} + +sub api_get_paste { + my $c = shift; + my $pasteid = $c->param('pasteid'); + + my $row = get_paste($pasteid); + + if ($row) { + my $data = { + paste => $row->{paste}, + when => $row->{when}, + username => $row->{who}, + description => $row->{desc}, + language => $row->{language}, + output => get_eval($pasteid, $row->{paste}) + }; + + $c->render(json => $data); + } else { +# 404 + return $c->reply->not_found; + } +}; + +sub api_post_paste { + my $c = shift; + + # TODO rate limiting + + my @args = map {($c->param($_))} qw/paste username description channel expire language/; + + my $id = insert_pastebin(@args); + my ($code, $who, $desc, $channel) = @args; + + # TODO select which one based on config + # TODO make this use the config, or http params for the url + + +# if (my $type = App::Spamfilter::is_spam($c, $who, $desc, $code)) { +# warn "I thought this was spam! $type"; +# } else { +# if ($channel) { # TODO config for allowing announcements +# IRC::Perlbot::announce($channel, $who, substr($desc, 0, 40), "https://perlbot.pl/pastebin/$id"); +## } +# } + + $c->render(json => { + url => "https://perlbot.pl/pastebin/$id", # TODO base url in config + id => $id, + }); + #$c->render(text => "post accepted! $id"); +}; + +## TODO make this come from a perlbot model +sub api_get_languages { + my $c=shift; + + $c->render(json => {languages => [ + {name => "perl", description => "Perl (blead/git)"}, + {name => "perl4", description => "Perl 4.0.36"}, + {name => "perl5.5", description => "Perl 5.5"}, + {name => "perl5.6", description => "Perl 5.6"}, + {name => "perl5.8", description => "Perl 5.8"}, + {name => "perl5.10", description => "Perl 5.10"}, + {name => "perl5.12", description => "Perl 5.12"}, + {name => "perl5.14", description => "Perl 5.14"}, + {name => "perl5.16", description => "Perl 5.16"}, + {name => "perl5.18", description => "Perl 5.18"}, + {name => "perl5.20", description => "Perl 5.20"}, + {name => "perl5.22", description => "Perl 5.22"}, + {name => "perl5.24", description => "Perl 5.24"}, + {name => "text", description => "Plain text"}, + ]}); +}; + +sub api_get_channels { + my $c=shift; + + $c->render(json => {channels => [ + {name => "localhost:perlbot:#perl", description => "Freenode #perl"}, + {name => "localhost:perlbot:#perlbot", description => "Freenode #perlbot"}, + {name => "localhost:perlbot:#perlcafe", description => "Freenode #perlcafe"}, + {name => "localhost:perlbot:#buutbot", description => "Freenode #buubot"}, + {name => "localhost:perlbot:##botparadise", description => "Freenode ##botparadise"}, + {name => "localhost:perlbot-magnet:#perl", description => "irc.perl.net #perl"}, + ]}); +}; + +1; diff --git a/lib/App/Controller/Eval.pm b/lib/App/Controller/Eval.pm new file mode 100644 index 0000000..ecaf41b --- /dev/null +++ b/lib/App/Controller/Eval.pm @@ -0,0 +1,31 @@ +package App::Controller::Eval; + +use strict; +use warnings; + +use Mojo::Base 'Mojolicious::Controller'; + +sub routes { + my ($class, $r) = @_; + + my $route = sub { + my ($method, $route, $action) = @_; + $r->$method($route)->to(controller => 'eval', action => $action); + }; + + $route->(post => '/eval' => 'run_eval'); +} + +sub run_eval { + my ($self) = @_; + my $data = $self->req->body_params; + + my $code = $data->param('code') // ''; + my $language = $data->param('language') // 'perl'; + + my $output = $self->eval->get_eval(undef, $code, $language); + + $c->render(json => {evalout => $output}); +}; + +1; diff --git a/lib/App/Controller/Paste.pm b/lib/App/Controller/Paste.pm new file mode 100644 index 0000000..a4bedcc --- /dev/null +++ b/lib/App/Controller/Paste.pm @@ -0,0 +1,121 @@ +package App::Controller::Paste; + +use strict; +use warnings; + +use App::Config; +use Mojo::Base 'Mojolicious::Controller'; + +sub routes { + my ($class, $r) = @_; + + my $route = sub { + my ($method, $route, $action) = @_; + $r->$method($route)->to(controller => 'paste', action => $action); + }; + + + $route->(get => '/pastebin' => 'to_root'); + $route->(get => '/paste' => 'to_root'); + $route->(get => '/edit' => 'to_root'); + + $route->(get => '/' => 'root'); + $route->(post => '/paste' => 'post_paste'); + $route->(get => '/edit/:pasteid' => 'edit_paste'); + $route->(get => '/raw/:pasteid' => 'raw_paste'); + $route->(get => '/pastebin/:pasteid' => 'get_paste'); +} + +sub to_root { + my $self = shift; + + $self->redirect_to('/'); +} + +sub root { + my $c = shift; + $c->stash({pastedata => q{}, channels => $cfg->{announce}{channels}, page_tmpl => 'editor.html'}); + $c->render("page"); +}; + +sub post_paste { + my $c = shift; + + my @args = map {($c->param($_))} qw/paste name desc chan expire language/; + + my $id = $c->paste->insert_pastebin(@args); + my ($code, $who, $desc, $channel) = @args; + + # TODO select which one based on config +# TODO make this use the config, or http params for the url + +# FIXME do this properly +# if (my $type = App::Spamfilter::is_spam($c, $who, $desc, $code)) { +# warn "I thought this was spam! $type"; +# } else { +# IRC::Perlbot::announce($c->param('chan'), $c->param('name'), substr($c->param('desc'), 0, 40), "https://perlbot.pl/pastebin/$id"); +# } + + $c->redirect_to('/pastebin/'.$id); + #$c->render(text => "post accepted! $id"); +}; + +sub edit_paste { + my $c = shift; + my $pasteid = $c->param('pasteid'); + + my $row = $dbh->selectrow_hashref("SELECT * FROM posts WHERE id = ? LIMIT 1", {}, $pasteid); + + if ($row->{when}) { + $c->stash({pastedata => $row->{paste}, channels =>$cfg->{announce}{channels}}); + $c->stash({page_tmpl => 'editor.html'}); + + $c->render('page'); + } else { + return $c->reply->not_found; + } +}; + +sub raw_paste { + my $c = shift; + my $pasteid = $c->param('pasteid'); + + my $row = get_paste($pasteid); + + + if ($row) { + $c->render(text => $row->{paste}, format => "txt"); + } else { + return $c->reply->not_found; + } + +}; +sub get_paste { + my $c = shift; + my $pasteid = $c->param('pasteid'); + + my $row = get_paste($pasteid); + + if ($row) { + $c->stash($row); + $c->stash({page_tmpl => 'viewer.html'}); + $c->stash({eval => get_eval($pasteid, $row->{paste}, $row->{lang})}); + $c->stash({paste_id => $pasteid}); + + $c->render('page'); + } else { + return $c->reply->not_found; + } + +}; + + +sub robots { + my ($c) = @_; + + $c->render(text => qq{User-agent: * +Disallow: /}, format => 'txt'); +}; + + +1; diff --git a/lib/Eval/Perlbot.pm b/lib/App/Model/Eval.pm similarity index 78% rename from lib/Eval/Perlbot.pm rename to lib/App/Model/Eval.pm index 302222b..f1d3561 100644 --- a/lib/Eval/Perlbot.pm +++ b/lib/App/Model/Eval.pm @@ -4,8 +4,7 @@ use strict; use warnings; use v5.22; -use Exporter qw/import/; -our @EXPORT=qw/get_eval/; +use Mojo::Base '-base'; use Encode qw/decode/; use POE::Filter::Reference; @@ -13,14 +12,16 @@ use POE::Filter::Reference; use App::Config; use App::Memcached; +has cfg => App::Config::get_config('evalserver'); + sub get_eval { - my ($paste_id, $code) = @_; + my ($self, $paste_id, $code, $lang) = @_; if ($paste_id && (my $cached = $memd->get($paste_id))) { return $cached; } else { my $filter = POE::Filter::Reference->new(); - my $socket = IO::Socket::INET->new( PeerAddr => $cfg->{evalserver}{server} //'localhost', PeerPort => $cfg->{evalserver}{port} //14400 ) + my $socket = IO::Socket::INET->new( PeerAddr => $self->cfg->{server} //'localhost', PeerPort => $self->cfg->{port} //14400 ) or die "error: cannot connect to eval server"; my $refs = $filter->put( [ { code => "perl $code" } ] ); # TODO make this support other langs diff --git a/lib/App/Model/Paste.pm b/lib/App/Model/Paste.pm new file mode 100644 index 0000000..0475806 --- /dev/null +++ b/lib/App/Model/Paste.pm @@ -0,0 +1,58 @@ +package App::Model::Paste; + +use strict; +use warnings; + +use DBI; +use Mojo::Base '-base'; + +# TODO config for dbname +has 'dbh' = DBI->connect("dbi:SQLite:dbname=pastes.db", "", "", {RaiseError => 1, sqlite_unicode => 1}); + +sub insert_pastebin { + my $self = shift; + my $dbh = $self->dbh; + my ($paste, $who, $what, $where, $expire, $lang) = @_; + + $expire = undef if !$expire; # make sure it's null if it's empty + + $dbh->do("INSERT INTO posts (paste, who, 'where', what, 'when', 'expiration', 'language') VALUES (?, ?, ?, ?, ?, ?, ?)", {}, $paste, $who, $where, $what, time(), $expire, $lang); + my $id = $dbh->last_insert_id('', '', 'posts', 'id'); + + # TODO this needs to retry when it fails. + my @chars = ('a'..'z', 1..9); + my $slug = join '', map {$chars[rand() *@chars]} 1..6; + $dbh->do("INSERT INTO slugs (post_id, slug) VAlUES (?, ?)", {}, $id, $slug); + + return $slug; +} + +sub get_paste { + my ($self, $pasteid) = shift; + my $dbh = $self->dbh; + my $row = $dbh->selectrow_hashref(q{ + SELECT p.* + FROM posts p + LEFT JOIN slugs s ON p.id = s.post_id + WHERE p.id = ? OR s.slug = ? + ORDER BY s.slug DESC + LIMIT 1 + }, {}, $pasteid, $pasteid); + + my $when = delete $row->{when}; + + if ($when) { + my $whendt = DateTime->from_epoch(epoch => $when); + + if (!$row->{expiration} || $whendt->clone()->add(hours => $row->{expiration}) >= DateTime->now()) { + $row->{when} = $whendt->iso8601; + return $row; + } else { + return undef; + } + } else { + return undef; + } +} + +1;