diff --git a/app.cfg b/app.cfg index 2a0d1e0..b0f5a08 100644 --- a/app.cfg +++ b/app.cfg @@ -18,7 +18,7 @@ address="localhost:11211" weight="2.5" [evalserver] -server="localhost:..." +server="localhost:14400" languages=[ "perl" ] # Config for a non-local server. Has a lower weight so that the local one gets checked first @@ -27,10 +27,11 @@ languages=[ "perl" ] # weight="1.0" [announce] -endpoint="localhost:1234" +host="localhost" +port="1784" protocol="perlbot" [announce.channels] -"freenode#perl"="Freenode #perl" -"freenode#perlbot"="Freenode #perlbot" -"magnet#perl"="irc.perl.net #perl" +"localhost:perlbot:#perl"="Freenode #perl" +"localhost:perlbot:#perlbot"="Freenode #perlbot" +#"localhost:perlbot-magnet:#perl"="irc.perl.net #perl" diff --git a/app.pl b/app.pl index 07917df..21a484a 100755 --- a/app.pl +++ b/app.pl @@ -15,7 +15,11 @@ use Encode qw/decode/; use Mojolicious::Lite; use Mojolicious::Plugin::TtRenderer; use POE::Filter::Reference; -use TOML; + +use App::Config; +use App::Memcached; +use Eval::Perlbot; +use IRC::Perlbot; plugin 'tt_renderer' => { template_options => { @@ -27,47 +31,6 @@ plugin 'tt_renderer' => { app->renderer->default_handler( 'tt' ); -my $cfg = do { - my $toml = do {open(my $fh, "<", "$Bin/app.cfg"); local $/; <$fh>}; -# With error checking - my ($data, $err) = from_toml($toml); - unless ($data) { - die "Error parsing toml: $err"; - } - $data; -}; - -my $memd; - -if ($cfg->{features}{memcached}) { - my $namespace = delete $cfg->{memcached}{namespace}; - $namespace .= "_".time() if (delete $cfg->{memcached}{unique_namespace}); - - # Only load these if we're using them - require Cache::Memcached::Fast; - require IO::Compress::Gzip; - require IO::Uncompress::Gunzip; - $memd = Cache::Memcached::Fast->new({ - namespace => $namespace // 'pastebin', - connect_timeout => 0.2, - io_timeout => 0.5, - close_on_error => 1, - compress_threshold => 1_000, - compress_ratio => 0.9, - compress_methods => [ \&IO::Compress::Gzip::gzip, - \&IO::Uncompress::Gunzip::gunzip ], - max_failures => 3, - failure_timeout => 2, - ketama_points => 150, - nowait => 1, - hash_namespace => 1, - serialize_methods => [ \&Storable::freeze, \&Storable::thaw ], - utf8 => 1, - max_size => 512 * 1024, - $cfg->{memcached}->%*, # let the config overwrite anything set here if they want - }); -}; - my $dbh = DBI->connect("dbi:SQLite:dbname=pastes.db", "", "", {RaiseError => 1}); $dbh->{sqlite_unicode} = 1; # hardcode some channels first @@ -81,31 +44,6 @@ sub insert_pastebin { return $id; } -sub get_eval { - my ($paste_id, $code) = @_; - - if ($cfg->{features}{memcached} && (my $cached = $memd->get($paste_id))) { - return $cached; - } else { - my $filter = POE::Filter::Reference->new(); - my $socket = IO::Socket::INET->new( PeerAddr => 'localhost', PeerPort => '14400' ) - or die "error: cannot connect to eval server"; - - my $refs = $filter->put( [ { code => "perl $code" } ] ); - - print $socket $refs->[0]; - my $output = do {local $/; <$socket>}; - close $socket; - my $result = $filter->get( [ $output ] ); - my $str = eval {decode("utf8", $result->[0]->[0])} // $result->[0]->[0]; - $str = eval {decode("utf8", $str)} // $str; # I don't know why i need to decode this twice. shurg. - $memd->set($paste_id, $str) if $cfg->{features}{memcached}; - - return $str; - } -} - - get '/' => sub { my $c = shift; $c->stash({pastedata => q{}, channels => $cfg->{announce}{channels}, page_tmpl => 'editor.html'}); @@ -122,6 +60,11 @@ post '/paste' => sub { my $id = insert_pastebin(@args); + # TODO select which one based on config +# TODO make this use the config, or http params for the url + my ($channel, $who, $what, $link) = @_; + IRC::Perlbot::announce($c->param('chan'), $c->param('name'), $c->param('desc'), "https://perlbot.pl/pastebin/$id"); + $c->redirect_to('/pastebin/'.$id); #$c->render(text => "post accepted! $id"); }; @@ -139,6 +82,7 @@ get '/edit/:pasteid' => sub { $c->render('page'); } else { # 404 + return $c->reply->not_found; } }; @@ -157,6 +101,7 @@ get '/pastebin/:pasteid' => sub { $c->render('page'); } else { # 404 + return $c->reply->not_found; } }; diff --git a/lib/App/Config.pm b/lib/App/Config.pm new file mode 100644 index 0000000..0f700a6 --- /dev/null +++ b/lib/App/Config.pm @@ -0,0 +1,24 @@ +package App::Config; + +use strict; +use warnings; + +use Exporter qw/import/; +use Data::Dumper; +use FindBin qw($Bin); + +use TOML; + +our @EXPORT=qw/$cfg/; + +our $cfg = do { + my $toml = do {open(my $fh, "<", "$Bin/app.cfg"); local $/; <$fh>}; +# With error checking + my ($data, $err) = from_toml($toml); + unless ($data) { + die "Error parsing toml: $err"; + } + $data; +}; + +1; diff --git a/lib/App/Memcached.pm b/lib/App/Memcached.pm new file mode 100644 index 0000000..a124160 --- /dev/null +++ b/lib/App/Memcached.pm @@ -0,0 +1,53 @@ +package App::Memcached; + +use strict; +use warnings; +no warnings "experimental::postderef"; +use feature "postderef", "postderef_qq"; + +use App::Config; +use Exporter qw/import/; + +our @EXPORT = qw/$memd/; + +our $memd; + +if ($cfg->{features}{memcached}) { + my $namespace = delete $cfg->{memcached}{namespace}; + $namespace .= "_".time() if (delete $cfg->{memcached}{unique_namespace}); + + # Only load these if we're using them + require Cache::Memcached::Fast; + require IO::Compress::Gzip; + require IO::Uncompress::Gunzip; + $memd = Cache::Memcached::Fast->new({ + namespace => $namespace // 'pastebin', + connect_timeout => 0.2, + io_timeout => 0.5, + close_on_error => 1, + compress_threshold => 1_000, + compress_ratio => 0.9, + compress_methods => [ \&IO::Compress::Gzip::gzip, + \&IO::Uncompress::Gunzip::gunzip ], + max_failures => 3, + failure_timeout => 2, + ketama_points => 150, + nowait => 1, + hash_namespace => 1, + serialize_methods => [ \&Storable::freeze, \&Storable::thaw ], + utf8 => 1, + max_size => 512 * 1024, + $cfg->{memcached}->%*, # let the config overwrite anything set here if they want + }); +} else { + $memd = bless {}, "App::Memcached::_mock"; +} + +# a mock object that does nothing but pretends to be the two functions i need +package App::Memcached::_mock; + +sub get { +} + +sub set { +} diff --git a/lib/Eval/Perlbot.pm b/lib/Eval/Perlbot.pm new file mode 100644 index 0000000..a852ddf --- /dev/null +++ b/lib/Eval/Perlbot.pm @@ -0,0 +1,38 @@ +package Eval::Perlbot; + +use strict; +use warnings; +use v5.22; + +use Exporter qw/import/; +our @EXPORT=qw/get_eval/; + +use Encode qw/decode/; +use POE::Filter::Reference; + +use App::Config; +use App::Memcached; + +sub get_eval { + my ($paste_id, $code) = @_; + + if (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 ) + or die "error: cannot connect to eval server"; + + my $refs = $filter->put( [ { code => "perl $code" } ] ); # TODO make this support other langs + + print $socket $refs->[0]; + my $output = do {local $/; <$socket>}; + close $socket; + my $result = $filter->get( [ $output ] ); + my $str = eval {decode("utf8", $result->[0]->[0])} // $result->[0]->[0]; + $str = eval {decode("utf8", $str)} // $str; # I don't know why i need to decode this twice. shurg. + $memd->set($paste_id, $str); + + return $str; + } +} diff --git a/lib/IRC/Perlbot.pm b/lib/IRC/Perlbot.pm new file mode 100644 index 0000000..6fb9462 --- /dev/null +++ b/lib/IRC/Perlbot.pm @@ -0,0 +1,25 @@ +package IRC::Perlbot; + +use strict; +use warnings; +use v5.22; +use Data::Dumper; + +#use Exporter qw/import/; +#our @EXPORT=qw/get_eval/; + +use App::Config; + +sub announce { + my ($channel, $who, $what, $link) = @_; + + print Dumper($cfg->{announce}); + + my $socket = IO::Socket::INET->new( PeerAddr => $cfg->{announce}{server} //'localhost', PeerPort => $cfg->{announce}{port} //1784 ) + or die "error: cannot connect to announce server"; + + print $socket "$channel\x1E$link\x1E$who\x1E$what\n"; + close($socket); +} + +1; diff --git a/pastes.db b/pastes.db index 6d8de0a..bdbb9ff 100644 Binary files a/pastes.db and b/pastes.db differ