From: Steinar H. Gunderson Date: Thu, 19 Nov 2015 00:16:54 +0000 (+0100) Subject: Move from mod_perl to being a PSGI app. X-Git-Url: https://git.sesse.net/?p=pr0n;a=commitdiff_plain;h=09260885c52013320acd21d7ce262e12def7301f Move from mod_perl to being a PSGI app. You can still run under mod_perl if you want to, but the default configuration is now PSGI via Starlet. Unfortunately the nice meets_requirement() checks are no longer there, but Varnish in front should handle that for us. --- diff --git a/doc/README b/doc/README index 6e19b1a..ec68afa 100644 --- a/doc/README +++ b/doc/README @@ -5,85 +5,44 @@ any of the images on pr0n.sesse.net etc.) is licensed under the GNU General Public License, version 2. For the full license text, see the COPYING file. Documentation? Forget it; if you can't set it up, use something else. You can -have a typical Apache 2 vhost snippet, though: +have a typical Varnish snippet, though: + +backend pr0n { + .host = "127.0.0.1"; + .port = "5015"; +} + +sub vcl_recv { + if (req.http.host == "pr0n.sesse.net") { + set req.backend_hint = pr0n; + } +} + +sub vcl_deliver { + if (resp.http.x-varnish-host && resp.http.x-pr0n-purge) { + set resp.http.escaped-regex = regsuball(resp.http.x-pr0n-purge, "\\", "\\\\"); + ban ( "obj.http.x-varnish-host == " + resp.http.x-varnish-host + " && obj.http.x-varnish-url ~ " + resp.http.escaped-regex ); + unset resp.http.escaped-regex; + } + unset resp.http.x-varnish-host; + unset resp.http.x-varnish-url; + unset resp.http.x-pr0n-purge; +} + +sub vcl_backend_response { + if (bereq.http.host == "pr0n.sesse.net") { + set beresp.ttl = 1w; + set beresp.http.x-varnish-host = bereq.http.host; + set beresp.http.x-varnish-url = bereq.url; + if (beresp.http.content-type ~ "^(text/html|text/plain|text/xml|text/css|application/x-javascript|application/javascript)") { + set beresp.do_gzip = true; + } + } else { + unset beresp.http.x-varnish-host; + } +} + +To redeploy after changes: + + sudo service pr0n reload && sudo varnishadm 'ban obj.http.x-varnish-host ~ "."' - - ServerAdmin sgunderson@bigfoot.com - DocumentRoot /srv/pr0n.sesse.net - ServerName pr0n.sesse.net - ServerAlias pr0n.sesse.net bilder.knatten.com pannekake.samfundet.no - - LogLevel info - ErrorLog /var/log/apache2/error-pr0n.sesse.net.log - CustomLog /var/log/apache2/access-pr0n.sesse.net.log combined - - ServerSignature On - PerlSwitches -wT - - # Keep this on during debugging -# PerlModule Apache2::Reload -# PerlInitHandler Apache2::Reload -# PerlSetVar ReloadAll Off -# PerlSetVar ReloadModules "Sesse::pr0n::*" -# PerlSetVar ReloadConstantRedefineWarnings Off - - # Share the loadavg module - PerlModule Sesse::pr0n::Overload - - PerlSetVar ImageBase /srv/pr0n.sesse.net/ - PerlSetVar TemplateBase /srv/pr0n.sesse.net/templates - PerlSetVar OverloadMode Off - PerlSetVar OverloadEnableThreshold 100.0 - PerlSetVar OverloadDisableThreshold 5.0 - - # All URLs are handled by the central pr0n module - - SetHandler modperl - PerlResponseHandler Sesse::pr0n::pr0n - - - - - ServerAdmin sgunderson@bigfoot.com - DocumentRoot /srv/pr0n.sesse.net - ServerName pr0n.sesse.net - ServerAlias pr0n.sesse.net bilder.knatten.com pannekake.samfundet.no - - LogLevel info - ErrorLog /var/log/apache2/error-pr0n.sesse.net.log - CustomLog /var/log/apache2/access-pr0n.sesse.net.log combined - - ServerSignature On - PerlSwitches -wT - - SSLEngine on - SSLCertificateFile ssl/pr0n.sesse.net.crt - SSLCertificateKeyFile ssl/pr0n.sesse.net.key - - # Keep this on during debugging -# PerlModule Apache2::Reload -# PerlInitHandler Apache2::Reload -# PerlSetVar ReloadAll Off -# PerlSetVar ReloadModules "Sesse::pr0n::*" -# PerlSetVar ReloadConstantRedefineWarnings Off - - # Share the loadavg module - PerlModule Sesse::pr0n::Overload - - PerlSetVar ImageBase /srv/pr0n.sesse.net/ - PerlSetVar TemplateBase /srv/pr0n.sesse.net/templates - PerlSetVar OverloadMode Off - PerlSetVar OverloadEnableThreshold 100.0 - PerlSetVar OverloadDisableThreshold 5.0 - - # All URLs are handled by the central pr0n module - - SetHandler modperl - PerlResponseHandler Sesse::pr0n::pr0n - - - -Also, mod_deflate is recommended; just install it and use the default -configuration, and it will work transparently. (You might want to add -text/css and application/x-javascript to the list of compressed -formats, but it's not really _that_ important.) diff --git a/doc/modules.txt b/doc/modules.txt index c2acc00..c0b88a6 100644 --- a/doc/modules.txt +++ b/doc/modules.txt @@ -1,8 +1,8 @@ Program/module name Debian package Usage -mod_perl2 libapache2-mod-perl2 Running it all :-) -apreq2 libapache2-request-perl Parsing CGI parameters - libapache2-mod-apreq2 +Starlet starlet PSGI web server +HTTP::Parser::XS libhttp-parser-xs-perl Faster Starlet +IO::File::WithPath libio-file-withpath-perl Sending files PerlMagick perlmagick Scaling etc. MIME::Types libmime-types-perl Sending the right MIME types DBD::Pg libdbd-pg-perl PostgreSQL connection diff --git a/files/faq.html b/files/faq.html index 34acc3d..b509bd8 100644 --- a/files/faq.html +++ b/files/faq.html @@ -87,10 +87,11 @@

pr0n currently runs on two Intel E5-2650v3 (2x10 cores at 2.30GHz) with 64GB RAM and SATA disks, with some SSDs in front for cache. (The server does a lot of other stuff besides running pr0n, of - course.) pr0n itself is a custom-made system by myself, tightly coupled - into Apache 2.4, - mod_perl 2.0, - ImageMagick 6.x + course.) pr0n itself is a custom-made system by myself, + a PSGI + app server running under Starlet + behind Varnish 4.1, + using ImageMagick 6.x (as well as various other Perl modules) and qscale, using PostgreSQL 9.4 as the back-end @@ -148,7 +149,7 @@ on IRC as Sesse on EFnet, IRCnet, Freenode or OFTC.

-

pr0n v2.81, +

pr0n v3.00-pre, © 2004–2015 Steinar H. Gunderson.

diff --git a/perl/Sesse/pr0n/Common.pm b/perl/Sesse/pr0n/Common.pm index 435beea..0569ef9 100644 --- a/perl/Sesse/pr0n/Common.pm +++ b/perl/Sesse/pr0n/Common.pm @@ -6,17 +6,12 @@ use Sesse::pr0n::Overload; use Sesse::pr0n::QscaleProxy; use Sesse::pr0n::Templates; -use Apache2::RequestRec (); # for $r->content_type -use Apache2::RequestIO (); # for $r->print -use Apache2::Const -compile => ':common'; -use Apache2::Log; -use ModPerl::Util; - use Carp; use Encode; use DBI; use DBD::Pg; use Image::Magick; +use IO::String; use POSIX; use Digest::SHA; use Digest::HMAC_SHA1; @@ -39,7 +34,7 @@ BEGIN { require Sesse::pr0n::Config_local; }; - $VERSION = "v2.81"; + $VERSION = "v3.00-pre"; @ISA = qw(Exporter); @EXPORT = qw(&error &dberror); %EXPORT_TAGS = qw(); @@ -50,7 +45,7 @@ BEGIN { or die "Couldn't connect to PostgreSQL database: " . DBI->errstr; our $mimetypes = new MIME::Types; - Apache2::ServerUtil->server->log_error("Initializing pr0n $VERSION"); + print STDERR "Initializing pr0n $VERSION\n"; } END { our $dbh; @@ -66,42 +61,46 @@ sub error { $status = 500; $title = "Internal server error"; } + + my $res = Plack::Response->new($status); + my $io = IO::String->new; $r->content_type('text/html; charset=utf-8'); - $r->status($status); - header($r, $title); - $r->print("

Error: $err

\n"); - footer($r); + header($r, $io, $title); + $io->print("

Error: $err

\n"); + footer($r, $io); - $r->log->error($err); - $r->log->error("Stack trace follows: " . Carp::longmess()); + log_error($r, $err); + log_error($r, "Stack trace follows: " . Carp::longmess()); - ModPerl::Util::exit(); + $io->setpos(0); + $res->body($io); + return $res; } sub dberror { my ($r,$err) = @_; - error($r, "$err (DB error: " . $dbh->errstr . ")"); + return error($r, "$err (DB error: " . $dbh->errstr . ")"); } sub header { - my ($r,$title) = @_; + my ($r, $io, $title) = @_; $r->content_type("text/html; charset=utf-8"); # Fetch quote if we're itk-bilder.samfundet.no my $quote = ""; - if ($r->get_server_name eq 'itk-bilder.samfundet.no') { + if (Sesse::pr0n::Common::get_server_name($r) eq 'itk-bilder.samfundet.no') { $quote = LWP::Simple::get("http://itk.samfundet.no/include/quotes.cli.php"); $quote = "Error: Could not fetch quotes." if (!defined($quote)); } - Sesse::pr0n::Templates::print_template($r, "header", { title => $title, quotes => $quote }); + Sesse::pr0n::Templates::print_template($r, $io, "header", { title => $title, quotes => $quote }); } sub footer { - my ($r) = @_; - Sesse::pr0n::Templates::print_template($r, "footer", + my ($r, $io) = @_; + Sesse::pr0n::Templates::print_template($r, $io, "footer", { version => $Sesse::pr0n::Common::VERSION }); } @@ -183,20 +182,20 @@ sub pretty_unescape { } sub print_link { - my ($r, $title, $baseurl, $param, $defparam, $accesskey) = @_; + my ($io, $title, $baseurl, $param, $defparam, $accesskey) = @_; my $str = "print($str); + $io->print($str); } sub get_dbh { # Check that we are alive if (!(defined($dbh) && $dbh->ping)) { # Try to reconnect - Apache2::ServerUtil->server->log_error("Lost contact with PostgreSQL server, trying to reconnect..."); + print STDERR "Lost contact with PostgreSQL server, trying to reconnect...\n"; unless ($dbh = DBI->connect("dbi:Pg:dbname=pr0n;host=" . $Sesse::pr0n::Config::db_host, $Sesse::pr0n::Config::db_username, $Sesse::pr0n::Config::db_password)) { $dbh = undef; @@ -207,15 +206,10 @@ sub get_dbh { return $dbh; } -sub get_base { - my $r = shift; - return $r->dir_config('ImageBase'); -} - sub get_disk_location { my ($r, $id) = @_; my $dir = POSIX::floor($id / 256); - return get_base($r) . "images/$dir/$id.jpg"; + return $Sesse::pr0n::Config::image_base . "images/$dir/$id.jpg"; } sub get_cache_location { @@ -223,14 +217,14 @@ sub get_cache_location { my $dir = POSIX::floor($id / 256); if ($infobox eq 'both') { - return get_base($r) . "cache/$dir/$id-$width-$height.jpg"; + return $Sesse::pr0n::Config::image_base . "cache/$dir/$id-$width-$height.jpg"; } elsif ($infobox eq 'nobox') { - return get_base($r) . "cache/$dir/$id-$width-$height-nobox.jpg"; + return $Sesse::pr0n::Config::image_base . "cache/$dir/$id-$width-$height-nobox.jpg"; } else { if ($dpr == 1) { - return get_base($r) . "cache/$dir/$id-$width-$height-box.png"; + return $Sesse::pr0n::Config::image_base . "cache/$dir/$id-$width-$height-box.png"; } else { - return get_base($r) . "cache/$dir/$id-$width-$height-box\@$dpr.png"; + return $Sesse::pr0n::Config::image_base . "cache/$dir/$id-$width-$height-box\@$dpr.png"; } } } @@ -239,15 +233,15 @@ sub ensure_disk_location_exists { my ($r, $id) = @_; my $dir = POSIX::floor($id / 256); - my $img_dir = get_base($r) . "/images/$dir/"; + my $img_dir = $Sesse::pr0n::Config::image_base . "/images/$dir/"; if (! -d $img_dir) { - $r->log->info("Need to create new image directory $img_dir"); + log_info($r, "Need to create new image directory $img_dir"); mkdir($img_dir) or die "Couldn't create new image directory $img_dir"; } - my $cache_dir = get_base($r) . "/cache/$dir/"; + my $cache_dir = $Sesse::pr0n::Config::image_base . "/cache/$dir/"; if (! -d $cache_dir) { - $r->log->info("Need to create new cache directory $cache_dir"); + log_info($r, "Need to create new cache directory $cache_dir"); mkdir($cache_dir) or die "Couldn't create new image directory $cache_dir"; } } @@ -256,7 +250,7 @@ sub get_mipmap_location { my ($r, $id, $width, $height) = @_; my $dir = POSIX::floor($id / 256); - return get_base($r) . "cache/$dir/$id-mipmap-$width-$height.jpg"; + return $Sesse::pr0n::Config::image_base . "cache/$dir/$id-mipmap-$width-$height.jpg"; } sub update_image_info { @@ -342,25 +336,25 @@ sub check_access { #return qw(sesse Sesse); - my $auth = $r->headers_in->{'authorization'}; + my $auth = $r->header('authorization'); if (!defined($auth)) { - output_401($r); return undef; } if ($auth =~ /^Basic ([a-zA-Z0-9+\/]+=*)$/) { return check_basic_auth($r, $1); } - output_401($r); return undef; } -sub output_401 { - my ($r, %options) = @_; - $r->content_type('text/plain; charset=utf-8'); - $r->status(401); - $r->headers_out->{'www-authenticate'} = 'Basic realm="pr0n.sesse.net"'; +sub generate_401 { + my ($r) = @_; + my $res = Plack::Response->new(401); + $res->content_type('text/plain; charset=utf-8'); + $res->status(401); + $res->header('WWW-Authenticate' => 'Basic realm="pr0n.sesse.net"'); - $r->print("Need authorization\n"); + $res->body("Need authorization\n"); + return $res; } sub check_basic_auth { @@ -370,7 +364,7 @@ sub check_basic_auth { my ($user, $takenby) = extract_takenby($raw_user); my $ref = $dbh->selectrow_hashref('SELECT sha1password,cryptpassword FROM users WHERE username=? AND vhost=?', - undef, $user, $r->get_server_name); + undef, $user, Sesse::pr0n::Common::get_server_name($r)); my ($sha1_matches, $bcrypt_matches) = (0, 0); if (defined($ref) && defined($ref->{'sha1password'})) { $sha1_matches = (Digest::SHA::sha1_base64($pass) eq $ref->{'sha1password'}); @@ -381,11 +375,10 @@ sub check_basic_auth { if (!defined($ref) || (!$sha1_matches && !$bcrypt_matches)) { $r->content_type('text/plain; charset=utf-8'); - $r->log->warn("Authentication failed for $user/$takenby"); - output_401($r); + log_warn($r, "Authentication failed for $user/$takenby"); return undef; } - $r->log->info("Authentication succeeded for $user/$takenby"); + log_info($r, "Authentication succeeded for $user/$takenby"); # Make sure we can use bcrypt authentication in the future with this password. # Also remove old-style SHA1 password when we migrate. @@ -394,9 +387,9 @@ sub check_basic_auth { my $hash = "\$2a\$07\$" . Crypt::Eksblowfish::Bcrypt::en_base64($salt); my $cryptpassword = Crypt::Eksblowfish::Bcrypt::bcrypt($pass, $hash); $dbh->do('UPDATE users SET sha1password=NULL,cryptpassword=? WHERE username=? AND vhost=?', - undef, $cryptpassword, $user, $r->get_server_name) + undef, $cryptpassword, $user, Sesse::pr0n::Common::get_server_name($r)) or die "Couldn't update: " . $dbh->errstr; - $r->log->info("Updated bcrypt hash for $user"); + log_info($r, "Updated bcrypt hash for $user"); } return ($user, $takenby); @@ -535,7 +528,7 @@ sub make_mipmap { } else { $cimg = $img->Clone(); } - $r->log->info("Making mipmap for $id: " . $mmres->[0] . " x " . $mmres->[1]); + log_info($r, "Making mipmap for $id: " . $mmres->[0] . " x " . $mmres->[1]); $cimg->Resize(width=>$mmres->[0], height=>$mmres->[1], filter=>'Lanczos', 'sampling-factor'=>'1x1'); $cimg->Strip(); my $err = $cimg->write( @@ -605,7 +598,7 @@ sub read_original_image { } if ($err) { - $r->log->warn("$physical_fname: $err"); + log_warn($r, "$physical_fname: $err"); $err =~ /(\d+)/; if ($1 >= 400) { undef $magick; @@ -642,7 +635,7 @@ sub ensure_cached { # If we are in overload mode (aka Slashdot mode), refuse to generate # new thumbnails. if (Sesse::pr0n::Overload::is_in_overload($r)) { - $r->log->warn("In overload mode, not scaling $id to $xres x $yres"); + log_warn($r, "In overload mode, not scaling $id to $xres x $yres"); error($r, 'System is in overload mode, not doing any scaling'); } @@ -692,7 +685,7 @@ sub ensure_cached { } $err = $img->write(filename => $cachename, quality => 90, depth => 8); - $r->log->info("New infobox cache: $width x $height for $id.jpg"); + log_info($r, "New infobox cache: $width x $height for $id.jpg"); return ($cachename, 'image/png'); } @@ -757,12 +750,12 @@ sub ensure_cached { ($xres, $yres) = ($nxres, $nyres); - $r->log->info("New cache: $nwidth x $nheight for $id.jpg"); + log_info($r, "New cache: $nwidth x $nheight for $id.jpg"); } undef $img; if ($err) { - $r->log->warn("$fname: $err"); + log_warn($r, "$fname: $err"); $err =~ /(\d+)/; if ($1 >= 400) { #@$magick = (); @@ -773,7 +766,7 @@ sub ensure_cached { # Update the SQL database if it doesn't contain the required info if (!defined($dbwidth) && defined($new_dbwidth)) { - $r->log->info("Updating width/height for $id: $new_dbwidth x $new_dbheight"); + log_info($r, "Updating width/height for $id: $new_dbwidth x $new_dbheight"); update_image_info($r, $id, $new_dbwidth, $new_dbheight); } @@ -963,7 +956,7 @@ sub gcd { } sub add_new_event { - my ($r, $dbh, $id, $date, $desc) = @_; + my ($r, $res, $dbh, $id, $date, $desc) = @_; my @errors = (); if (!defined($id) || $id =~ /^\s*$/ || $id !~ /^([a-zA-Z0-9-]+)$/) { @@ -980,14 +973,14 @@ sub add_new_event { return @errors; } - my $vhost = $r->get_server_name; + my $vhost = Sesse::pr0n::Common::get_server_name($r); $dbh->do("INSERT INTO events (event,date,name,vhost) VALUES (?,?,?,?)", undef, $id, $date, $desc, $vhost) or return ("Kunne ikke sette inn ny hendelse" . $dbh->errstr); $dbh->do("INSERT INTO last_picture_cache (vhost,event,last_picture) VALUES (?,?,NULL)", undef, $vhost, $id) or return ("Kunne ikke sette inn ny cache-rad" . $dbh->errstr); - purge_cache($r, "/"); + purge_cache($r, $res, "/"); return (); } @@ -1011,12 +1004,12 @@ sub guess_charset { # regex tacked onto a request into something useful. The elements given in # should not be regexes, though, as e.g. Squid will not be able to handle that. sub purge_cache { - my ($r, @elements) = @_; + my ($r, $res, @elements) = @_; return if (scalar @elements == 0); my @pe = (); for my $elem (@elements) { - $r->log->info("Purging $elem"); + log_info($r, "Purging $elem"); (my $e = $elem) =~ s/[.+*|()]/\\$&/g; push @pe, $e; } @@ -1028,7 +1021,7 @@ sub purge_cache { $regex .= "(" . join('|', @pe) . ")"; } $regex .= "(\\?.*)?\$"; - $r->headers_out->{'X-Pr0n-Purge'} = $regex; + $res->header('X-Pr0n-Purge' => $regex); } # Find a list of all cache URLs for a given image, given what we have on disk. @@ -1046,7 +1039,7 @@ sub get_all_cache_urls { my $filename = $ref->{'filename'}; $q->finish; - my $base = get_base($r) . "cache/$dir"; + my $base = $Sesse::pr0n::Config::image_base . "cache/$dir"; for my $file (<$base/$id-*>) { my $fname = File::Basename::basename($file); if ($fname =~ /^$id-mipmap-.*\.jpg$/) { @@ -1062,13 +1055,54 @@ sub get_all_cache_urls { } elsif ($fname =~ /^$id-(\d+)-(\d+)-box\.png$/) { push @ret, "/$event/$1x$2/box/$filename"; } else { - $r->log->warn("Couldn't find a purging URL for $fname"); + log_warn($r, "Couldn't find a purging URL for $fname"); } } return @ret; } +sub set_last_modified { + my ($res, $mtime) = @_; + + my $str = POSIX::strftime("%a, %d %b %Y %H:%M:%S %Z", localtime($mtime)); + $res->headers({ 'Last-Modified' => $str }); +} + +sub get_server_name { + my $r = shift; + my $host = $r->env->{'HTTP_HOST'}; + $host =~ s/:.*//; + return $host; +} + +sub log_info { + my ($r, $msg) = @_; + if (defined($r->logger)) { + $r->logger->({ level => 'info', message => $msg }); + } else { + print STDERR "[INFO] $msg\n"; + } +} + +sub log_warn { + my ($r, $msg) = @_; + if (defined($r->logger)) { + $r->logger->({ level => 'warn', message => $msg }); + } else { + print STDERR "[WARN] $msg\n"; + } +} + +sub log_error { + my ($r, $msg) = @_; + if (defined($r->logger)) { + $r->logger->({ level => 'error', message => $msg }); + } else { + print STDERR "[ERROR] $msg\n"; + } +} + 1; diff --git a/perl/Sesse/pr0n/Config.pm b/perl/Sesse/pr0n/Config.pm index e267c99..4e1d50c 100644 --- a/perl/Sesse/pr0n/Config.pm +++ b/perl/Sesse/pr0n/Config.pm @@ -2,10 +2,6 @@ # Copy this file to Config-local.pm and change the values there to # suit your own needs. # -# Note that most configuration is done in your vhost; this isn't, -# because it's persistent between sessions and we don't have access -# to the Apache configuration data then. -# package Sesse::pr0n::Config; use strict; use warnings; @@ -14,4 +10,10 @@ our $db_host = '127.0.0.1'; our $db_username = 'pr0n'; our $db_password = ''; +our $image_base = '/srv/pr0n.sesse.net/'; +our $template_base = '/srv/pr0n.sesse.net/templates'; +our $overload_mode = 0; +our $overload_enable_threshold = 100.0; +our $overload_disable_threshold = 30.0; + 1; diff --git a/perl/Sesse/pr0n/Image.pm b/perl/Sesse/pr0n/Image.pm index 372a9b1..4f6360a 100644 --- a/perl/Sesse/pr0n/Image.pm +++ b/perl/Sesse/pr0n/Image.pm @@ -16,12 +16,12 @@ sub handler { # Find the event and file name my ($event,$filename,$xres,$yres,$dpr); my $infobox = 'both'; - if ($r->uri =~ m#^/([a-zA-Z0-9-]+)/original/((?:no)?box/)?([a-zA-Z0-9._()-]+)$#) { + if ($r->path_info =~ m#^/([a-zA-Z0-9-]+)/original/((?:no)?box/)?([a-zA-Z0-9._()-]+)$#) { $event = $1; $filename = $3; $infobox = 'nobox' if (defined($2) && $2 eq 'nobox/'); $infobox = 'box' if (defined($2) && $2 eq 'box/'); - } elsif ($r->uri =~ m#^/([a-zA-Z0-9-]+)/(\d+)x(\d+)(?:\@(\d+(?:\.\d+)?))?/((?:no)?box/)?([a-zA-Z0-9._()-]+)$#) { + } elsif ($r->path_info =~ m#^/([a-zA-Z0-9-]+)/(\d+)x(\d+)(?:\@(\d+(?:\.\d+)?))?/((?:no)?box/)?([a-zA-Z0-9._()-]+)$#) { $event = $1; $filename = $6; $xres = $2; @@ -29,7 +29,7 @@ sub handler { $dpr = $4; $infobox = 'nobox' if (defined($5) && $5 eq 'nobox/'); $infobox = 'box' if (defined($5) && $5 eq 'box/'); - } elsif ($r->uri =~ m#^/([a-zA-Z0-9-]+)/((?:no)?box/)?([a-zA-Z0-9._()-]+)$#) { + } elsif ($r->path_info =~ m#^/([a-zA-Z0-9-]+)/((?:no)?box/)?([a-zA-Z0-9._()-]+)$#) { $event = $1; $filename = $3; $xres = -1; @@ -46,8 +46,8 @@ sub handler { # Look it up in the database my $ref = $dbh->selectrow_hashref('SELECT id,width,height FROM images WHERE event=? AND vhost=? AND filename=?', - undef, $event, $r->get_server_name, $filename); - error($r, "Could not find $event/$filename", 404, "File not found") unless (defined($ref)); + undef, $event, Sesse::pr0n::Common::get_server_name($r), $filename); + return error($r, "Could not find $event/$filename", 404, "File not found") unless (defined($ref)); $id = $ref->{'id'}; $dbwidth = $ref->{'width'}; @@ -57,25 +57,26 @@ sub handler { my ($fname, $mime_type) = Sesse::pr0n::Common::ensure_cached($r, $filename, $id, $dbwidth, $dbheight, $infobox, $dpr, $xres, $yres); # Output the image to the user + my $res = Plack::Response->new(200); + if (!defined($mime_type)) { $mime_type = Sesse::pr0n::Common::get_mimetype_from_filename($filename); } - $r->content_type($mime_type); + $res->content_type($mime_type); my (undef, undef, undef, undef, undef, undef, undef, $size, undef, $mtime) = stat($fname) - or error($r, "stat of $fname: $!"); + or return error($r, "stat of $fname: $!"); - $r->set_content_length($size); - $r->set_last_modified($mtime); - - # If the client can use cache, by all means do so - if ((my $rc = $r->meets_conditions) != Apache2::Const::OK) { - return $rc; - } + $res->content_length($size); + Sesse::pr0n::Common::set_last_modified($res, $mtime); - $r->sendfile($fname); + # # If the client can use cache, by all means do so + #if ((my $rc = $r->meets_conditions) != Apache2::Const::OK) { + # return $rc; + #} - return Apache2::Const::OK; + $res->content(IO::File::WithPath->new($fname)); + return $res; } 1; diff --git a/perl/Sesse/pr0n/Index.pm b/perl/Sesse/pr0n/Index.pm index fbe6d3f..8500f9b 100644 --- a/perl/Sesse/pr0n/Index.pm +++ b/perl/Sesse/pr0n/Index.pm @@ -3,22 +3,20 @@ use strict; use warnings; use Sesse::pr0n::Common qw(error dberror); -use Apache2::Request; use POSIX; sub handler { my $r = shift; - my $apr = Apache2::Request->new($r); my $dbh = Sesse::pr0n::Common::get_dbh(); my ($event, $abspath, $datesort, $tag); - if ($r->uri =~ /^\/\+all\/?/) { + if ($r->path_info =~ /^\/\+all\/?/) { $event = '+all'; $abspath = 1; $tag = undef; $datesort = 'DESC NULLS LAST'; - } elsif ($r->uri =~ /^\/\+tags\/([a-zA-Z0-9-]+)\/?$/) { + } elsif ($r->path_info =~ /^\/\+tags\/([a-zA-Z0-9-]+)\/?$/) { $tag = $1; $event = "+tags/$tag"; $abspath = 1; @@ -26,8 +24,8 @@ sub handler { $datesort = 'DESC NULLS LAST'; } else { # Find the event - $r->uri =~ /^\/([a-zA-Z0-9-]+)\/?$/ - or error($r, "Could not extract event"); + $r->path_info =~ /^\/([a-zA-Z0-9-]+)\/?$/ + or return error($r, "Could not extract event"); $event = $1; $abspath = 0; $tag = undef; @@ -35,17 +33,18 @@ sub handler { } # Fix common error: pr0n.sesse.net/event -> pr0n.sesse.net/event/ - if ($r->uri !~ /\/$/) { - $r->headers_out->{'location'} = $r->uri . "/"; - return Apache2::Const::REDIRECT; + if ($r->path_info !~ /\/$/) { + my $res = Plack::Response->new(301); + $res->header('Location' => $r->path_info . "/"); + return $res; } # Internal? (Ugly?) - if ($r->get_server_name =~ /internal/ || $r->get_server_name =~ /skoyen\.bilder\.knatten\.com/ || $r->get_server_name =~ /lia\.heimdal\.org/) { + if (Sesse::pr0n::Common::get_server_name($r) =~ /internal/ || + Sesse::pr0n::Common::get_server_name($r) =~ /skoyen\.bilder\.knatten\.com/ || + Sesse::pr0n::Common::get_server_name($r) =~ /lia\.heimdal\.org/) { my $user = Sesse::pr0n::Common::check_access($r); - if (!defined($user)) { - return Apache2::Const::OK; - } + return Sesse::pr0n::Common::generate_401($r) if (!defined($user)); } # Read the appropriate settings from the query string into the settings hash @@ -78,7 +77,7 @@ sub handler { # Any NEF files => default to processing my $ref = $dbh->selectrow_hashref("SELECT * FROM images WHERE vhost=? $where AND ( LOWER(filename) LIKE '%.nef' OR LOWER(filename) LIKE '%.cr2' ) LIMIT 1", - undef, $r->get_server_name) + undef, Sesse::pr0n::Common::get_server_name($r)) and $defsettings{'xres'} = $defsettings{'yres'} = undef; # Reduce the front page load when in overload mode. @@ -89,7 +88,7 @@ sub handler { my %settings = %defsettings; for my $s (qw(thumbxres thumbyres xres yres start num all infobox rot sel fullscreen model lens author)) { - my $val = $apr->param($s); + my $val = $r->param($s); if (defined($val) && $val =~ /^(\d+)$/) { $settings{$s} = $val; } @@ -154,47 +153,49 @@ sub handler { if ($event eq '+all' || defined($tag)) { $ref = $dbh->selectrow_hashref("SELECT EXTRACT(EPOCH FROM MAX(last_update)) AS last_update FROM last_picture_cache WHERE vhost=?", - undef, $r->get_server_name) - or error($r, "Could not list events", 404, "File not found"); + undef, Sesse::pr0n::Common::get_server_name($r)) + or return error($r, "Could not list events", 404, "File not found"); $date = undef; $name = Sesse::pr0n::Templates::fetch_template($r, 'all-event-title'); - $r->set_last_modified($ref->{'last_update'}); + Sesse::pr0n::Common::set_last_modified($r, $ref->{'last_update'}); } else { $ref = $dbh->selectrow_hashref("SELECT name,date,EXTRACT(EPOCH FROM last_update) AS last_update FROM events NATURAL JOIN last_picture_cache WHERE vhost=? AND event=?", - undef, $r->get_server_name, $event) - or error($r, "Could not find event $event", 404, "File not found"); + undef, Sesse::pr0n::Common::get_server_name($r), $event) + or return error($r, "Could not find event $event", 404, "File not found"); $date = HTML::Entities::encode_entities($ref->{'date'}); $name = HTML::Entities::encode_entities($ref->{'name'}); - $r->set_last_modified($ref->{'last_update'}); + Sesse::pr0n::Common::set_last_modified($r, $ref->{'last_update'}); } - # If the client can use cache, do so - if ((my $rc = $r->meets_conditions) != Apache2::Const::OK) { - return $rc; - } + # # If the client can use cache, do so + # if ((my $rc = $r->meets_conditions) != Apache2::Const::OK) { + # return $rc; + # } # Count the number of selected images. - $ref = $dbh->selectrow_hashref("SELECT COUNT(*) AS num_selected FROM images WHERE vhost=? $where AND selected=\'t\'", undef, $r->get_server_name); + $ref = $dbh->selectrow_hashref("SELECT COUNT(*) AS num_selected FROM images WHERE vhost=? $where AND selected=\'t\'", undef, Sesse::pr0n::Common::get_server_name($r)); my $num_selected = $ref->{'num_selected'}; # Find all images related to this event. my $limit = (defined($start) && defined($num) && !$settings{'fullscreen'}) ? (" LIMIT $num OFFSET " . ($start-1)) : ""; my $q = $dbh->prepare("SELECT *, (date - INTERVAL '6 hours')::date AS day FROM images WHERE vhost=? $where ORDER BY (date - INTERVAL '6 hours')::date $datesort,takenby,date,filename $limit") - or dberror($r, "prepare()"); - $q->execute($r->get_server_name) - or dberror($r, "image enumeration"); + or return dberror($r, "prepare()"); + $q->execute(Sesse::pr0n::Common::get_server_name($r)) + or return dberror($r, "image enumeration"); # Print the page itself + my $res = Plack::Response->new(200); + my $io = IO::String->new; if ($settings{'fullscreen'}) { - $r->content_type("text/html; charset=utf-8"); + $res->content_type("text/html; charset=utf-8"); if (defined($tag)) { - my $title = Sesse::pr0n::Templates::process_template($r, "tag-title", { tag => $tag }); - Sesse::pr0n::Templates::print_template($r, "fullscreen-header", { title => $title }); + my $title = Sesse::pr0n::Templates::process_template($res, $io, "tag-title", { tag => $tag }); + Sesse::pr0n::Templates::print_template($r, $io, "fullscreen-header", { title => $title }); } else { - Sesse::pr0n::Templates::print_template($r, "fullscreen-header", { title => "$name [$event]" }); + Sesse::pr0n::Templates::print_template($r, $io, "fullscreen-header", { title => "$name [$event]" }); } my @files = (); @@ -207,19 +208,19 @@ sub handler { for my $i (0..$#files) { my $line = sprintf " [ \"%s\", \"%s\", %d, %d ]", @{$files[$i]}; $line .= "," unless ($i == $#files); - $r->print($line . "\n"); + $io->print($line . "\n"); } my %settings_no_fullscreen = %settings; $settings_no_fullscreen{'fullscreen'} = 0; - my $returnurl = "http://" . $r->get_server_name . "/" . $event . "/" . + my $returnurl = "http://" . Sesse::pr0n::Common::get_server_name($r) . "/" . $event . "/" . Sesse::pr0n::Common::get_query_string(\%settings_no_fullscreen, \%defsettings); # *whistle* $returnurl =~ s/&/&/g; - Sesse::pr0n::Templates::print_template($r, "fullscreen-footer", { + Sesse::pr0n::Templates::print_template($r, $io, "fullscreen-footer", { returnurl => $returnurl, start => $settings{'start'} - 1, sel => $settings{'sel'}, @@ -227,26 +228,26 @@ sub handler { }); } else { if (defined($tag)) { - my $title = Sesse::pr0n::Templates::process_template($r, "tag-title", { tag => $tag }); - Sesse::pr0n::Common::header($r, $title); + my $title = Sesse::pr0n::Templates::process_template($r, $io, "tag-title", { tag => $tag }); + Sesse::pr0n::Common::header($r, $io, $title); } else { - Sesse::pr0n::Common::header($r, "$name [$event]"); + Sesse::pr0n::Common::header($r, $io, "$name [$event]"); } if (defined($date)) { - Sesse::pr0n::Templates::print_template($r, "date", { date => $date }); + Sesse::pr0n::Templates::print_template($r, $io, "date", { date => $date }); } if (Sesse::pr0n::Overload::is_in_overload($r)) { - Sesse::pr0n::Templates::print_template($r, "overloadmode"); + Sesse::pr0n::Templates::print_template($r, $io, "overloadmode"); } - print_thumbsize($r, $event, \%settings, \%defsettings); - print_viewres($r, $event, \%settings, \%defsettings); - print_pagelimit($r, $event, \%settings, \%defsettings); - print_infobox($r, $event, \%settings, \%defsettings); - print_selected($r, $event, \%settings, \%defsettings) if ($num_selected > 0); - print_fullscreen($r, $event, \%settings, \%defsettings); - print_nextprev($r, $event, $where, \%settings, \%defsettings); + print_thumbsize($r, $io, $event, \%settings, \%defsettings); + print_viewres($r, $io, $event, \%settings, \%defsettings); + print_pagelimit($r, $io, $event, \%settings, \%defsettings); + print_infobox($r, $io, $event, \%settings, \%defsettings); + print_selected($r, $io, $event, \%settings, \%defsettings) if ($num_selected > 0); + print_fullscreen($r, $io, $event, \%settings, \%defsettings); + print_nextprev($r, $io, $event, $where, \%settings, \%defsettings); if (1 || $event ne '+all') { # Find the equipment used @@ -260,7 +261,7 @@ sub handler { GROUP BY 1,2 ORDER BY 1,2") or die "Couldn't prepare to find equipment: $!"; - $eq->execute($r->get_server_name) + $eq->execute(Sesse::pr0n::Common::get_server_name($r)) or die "Couldn't find equipment: $!"; my @equipment = (); @@ -281,7 +282,7 @@ sub handler { $eq->finish; if (scalar @equipment > 0) { - Sesse::pr0n::Templates::print_template($r, "equipment-start"); + Sesse::pr0n::Templates::print_template($r, $io, "equipment-start"); for my $e (@equipment) { my $eqspec = $e->{'model'}; $eqspec .= ', ' . $e->{'lens'} if (defined($e->{'lens'})); @@ -306,12 +307,12 @@ sub handler { # This isn't correct for all languages. Fix if we ever need to care. :-) if ($e->{'num'} == 1) { - Sesse::pr0n::Templates::print_template($r, "equipment-item-singular", { eqspec => $eqspec, filterurl => $url, action => $action }); + Sesse::pr0n::Templates::print_template($r, $io, "equipment-item-singular", { eqspec => $eqspec, filterurl => $url, action => $action }); } else { - Sesse::pr0n::Templates::print_template($r, "equipment-item", { eqspec => $eqspec, num => $e->{'num'}, filterurl => $url, action => $action }); + Sesse::pr0n::Templates::print_template($r, $io, "equipment-item", { eqspec => $eqspec, num => $e->{'num'}, filterurl => $url, action => $action }); } } - Sesse::pr0n::Templates::print_template($r, "equipment-end"); + Sesse::pr0n::Templates::print_template($r, $io, "equipment-end"); } } @@ -321,8 +322,8 @@ sub handler { # Print out all thumbnails if ($rot == 1) { - $r->print("
\n"); - $r->print(" \n"); + $io->print(" \n"); + $io->print(" \n"); } while (my $ref = $q->fetchrow_hashref()) { @@ -336,7 +337,7 @@ sub handler { my $groupkey = $takenby . $day; if ($groupkey ne $lastupl) { - $r->print("

\n\n") if ($lastupl ne "" && $rot != 1); + $io->print("

\n\n") if ($lastupl ne "" && $rot != 1); $lastupl = $groupkey; my %newsettings = %settings; @@ -354,13 +355,13 @@ sub handler { my $url = "/$event/" . Sesse::pr0n::Common::get_query_string(\%newsettings, \%defsettings); - $r->print("

"); - Sesse::pr0n::Templates::print_template($r, "submittedby", { author => $takenby, action => $action, filterurl => $url, date => $day }); - print_fullscreen_fromhere($r, $event, \%settings, \%defsettings, $img_num); - $r->print("

\n"); + $io->print("

"); + Sesse::pr0n::Templates::print_template($r, $io, "submittedby", { author => $takenby, action => $action, filterurl => $url, date => $day }); + print_fullscreen_fromhere($r, $io, $event, \%settings, \%defsettings, $img_num); + $io->print("

\n"); if ($rot != 1) { - $r->print("

\n"); + $io->print("

\n"); } } @@ -386,20 +387,20 @@ sub handler { } if ($rot == 1) { - $r->print("

"); + $io->print("

"); } else { - $r->print(" "); + $io->print(" "); } - $r->print("\"\"$imgsz\n"); + $io->print("\"\"$imgsz\n"); if ($rot == 1) { - $r->print(" 90 print(" 90 {'id'} . "-90\" />\n"); - $r->print(" 180 print(" 180 {'id'} . "-180\" />\n"); - $r->print(" 270 print(" 270 {'id'} . "-270\" />\n"); - $r->print("        " . + $io->print("        " . "     Del {'id'} . "\" />

\n"); } @@ -407,17 +408,19 @@ sub handler { } if ($rot == 1) { - $r->print(" \n"); - $r->print("
\n"); + $io->print(" \n"); + $io->print(" \n"); } else { - $r->print("

\n"); + $io->print("

\n"); } - print_nextprev($r, $event, $where, \%settings, \%defsettings); - Sesse::pr0n::Common::footer($r); + print_nextprev($r, $io, $event, $where, \%settings, \%defsettings); + Sesse::pr0n::Common::footer($r, $io); } - return Apache2::Const::OK; + $io->setpos(0); + $res->body($io); + return $res; } sub eq_with_undef { @@ -429,11 +432,11 @@ sub eq_with_undef { } sub print_changes { - my ($r, $event, $template, $settings, $defsettings, $var1, $var2, $alternatives) = @_; + my ($r, $io, $event, $template, $settings, $defsettings, $var1, $var2, $alternatives) = @_; my $title = Sesse::pr0n::Templates::fetch_template($r, $template); chomp $title; - $r->print("

$title:\n"); + $io->print("

$title:\n"); for my $a (@$alternatives) { my $text; @@ -455,45 +458,45 @@ sub print_changes { $newsettings{$var2} = $v2; } - $r->print(" "); + $io->print(" "); # Check if these settings are current (print only label) if (eq_with_undef($settings->{$var1}, $newsettings{$var1}) && eq_with_undef($settings->{$var2}, $newsettings{$var2})) { - $r->print($text); + $io->print($text); } else { - Sesse::pr0n::Common::print_link($r, $text, "/$event/", \%newsettings, $defsettings); + Sesse::pr0n::Common::print_link($io, $text, "/$event/", \%newsettings, $defsettings); } - $r->print("\n"); + $io->print("\n"); } - $r->print("

\n"); + $io->print("

\n"); } sub print_thumbsize { - my ($r, $event, $settings, $defsettings) = @_; + my ($r, $io, $event, $settings, $defsettings) = @_; my @alternatives = qw(80x64 120x96 160x128 240x192 320x256); - print_changes($r, $event, 'thumbsize', $settings, $defsettings, + print_changes($r, $io, $event, 'thumbsize', $settings, $defsettings, 'thumbxres', 'thumbyres', \@alternatives); } sub print_viewres { - my ($r, $event, $settings, $defsettings) = @_; + my ($r, $io, $event, $settings, $defsettings) = @_; my @alternatives = qw(320x256 512x384 640x480 800x600 1024x768 1152x864 1280x960 1400x1050 1600x1200 1920x1440 2048x1536 2304x1728); chomp (my $unlimited = Sesse::pr0n::Templates::fetch_template($r, 'viewres-unlimited')); chomp (my $original = Sesse::pr0n::Templates::fetch_template($r, 'viewres-original')); push @alternatives, [ $unlimited, -2, -2 ]; push @alternatives, [ $original, -1, -1 ]; - print_changes($r, $event, 'viewres', $settings, $defsettings, + print_changes($r, $io, $event, 'viewres', $settings, $defsettings, 'xres', 'yres', \@alternatives); } sub print_pagelimit { - my ($r, $event, $settings, $defsettings) = @_; + my ($r, $io, $event, $settings, $defsettings) = @_; my $title = Sesse::pr0n::Templates::fetch_template($r, 'imgsperpage'); chomp $title; - $r->print("

$title:\n"); + $io->print("

$title:\n"); # Get choices chomp (my $unlimited = Sesse::pr0n::Templates::fetch_template($r, 'imgsperpage-unlimited')); @@ -509,49 +512,49 @@ sub print_pagelimit { $newsettings{'num'} = $num; } - $r->print(" "); + $io->print(" "); if (eq_with_undef($settings->{'num'}, $newsettings{'num'})) { - $r->print($num); + $io->print($num); } else { - Sesse::pr0n::Common::print_link($r, $num, "/$event/", \%newsettings, $defsettings); + Sesse::pr0n::Common::print_link($io, $num, "/$event/", \%newsettings, $defsettings); } - $r->print("\n"); + $io->print("\n"); } - $r->print("

\n"); + $io->print("

\n"); } sub print_infobox { - my ($r, $event, $settings, $defsettings) = @_; + my ($r, $io, $event, $settings, $defsettings) = @_; chomp (my $title = Sesse::pr0n::Templates::fetch_template($r, 'infobox')); chomp (my $on = Sesse::pr0n::Templates::fetch_template($r, 'infobox-on')); chomp (my $off = Sesse::pr0n::Templates::fetch_template($r, 'infobox-off')); - $r->print("

$title:\n"); + $io->print("

$title:\n"); my %newsettings = %$settings; if ($settings->{'infobox'} == 1) { - $r->print($on); + $io->print($on); } else { $newsettings{'infobox'} = 1; - Sesse::pr0n::Common::print_link($r, $on, "/$event/", \%newsettings, $defsettings); + Sesse::pr0n::Common::print_link($io, $on, "/$event/", \%newsettings, $defsettings); } - $r->print(' '); + $io->print(' '); if ($settings->{'infobox'} == 0) { - $r->print($off); + $io->print($off); } else { $newsettings{'infobox'} = 0; - Sesse::pr0n::Common::print_link($r, $off, "/$event/", \%newsettings, $defsettings); + Sesse::pr0n::Common::print_link($io, $off, "/$event/", \%newsettings, $defsettings); } - $r->print('

'); + $io->print('

'); } sub print_nextprev { - my ($r, $event, $where, $settings, $defsettings) = @_; + my ($r, $io, $event, $where, $settings, $defsettings) = @_; my $start = $settings->{'start'}; my $num = $settings->{'num'}; my $dbh = Sesse::pr0n::Common::get_dbh(); @@ -561,8 +564,8 @@ sub print_nextprev { # determine total number my $ref = $dbh->selectrow_hashref("SELECT count(*) AS num_images FROM images WHERE vhost=? $where", - undef, $r->get_server_name) - or dberror($r, "image enumeration"); + undef, Sesse::pr0n::Common::get_server_name($r)) + or return dberror($r, "image enumeration"); my $num_images = $ref->{'num_images'}; return if ($start == 1 && $start + $num >= $num_images); @@ -572,7 +575,7 @@ sub print_nextprev { $end = $num_images; } - $r->print("

\n"); + $io->print("

\n"); # Previous if ($start > 1) { @@ -589,12 +592,12 @@ sub print_nextprev { $newsettings{'start'} = $newstart; chomp (my $title = Sesse::pr0n::Templates::fetch_template($r, 'prevpage')); chomp (my $accesskey = Sesse::pr0n::Templates::fetch_template($r, 'prevaccesskey')); - Sesse::pr0n::Common::print_link($r, "$title ($newstart-$newend)\n", "/$event/", \%newsettings, $defsettings, $accesskey); + Sesse::pr0n::Common::print_link($io, "$title ($newstart-$newend)\n", "/$event/", \%newsettings, $defsettings, $accesskey); } # This chomp (my $title = Sesse::pr0n::Templates::fetch_template($r, 'thispage')); - $r->print(" $title ($start-$end)\n"); + $io->print(" $title ($start-$end)\n"); # Next if ($end < $num_images) { @@ -608,57 +611,57 @@ sub print_nextprev { $newsettings{'start'} = $newstart; chomp (my $title = Sesse::pr0n::Templates::fetch_template($r, 'nextpage')); chomp (my $accesskey = Sesse::pr0n::Templates::fetch_template($r, 'nextaccesskey')); - Sesse::pr0n::Common::print_link($r, "$title ($newstart-$newend)", "/$event/", \%newsettings, $defsettings, $accesskey); + Sesse::pr0n::Common::print_link($io, "$title ($newstart-$newend)", "/$event/", \%newsettings, $defsettings, $accesskey); } - $r->print("

\n"); + $io->print("

\n"); } sub print_selected { - my ($r, $event, $settings, $defsettings) = @_; + my ($r, $io, $event, $settings, $defsettings) = @_; chomp (my $title = Sesse::pr0n::Templates::fetch_template($r, 'show')); chomp (my $all = Sesse::pr0n::Templates::fetch_template($r, 'show-all')); chomp (my $sel = Sesse::pr0n::Templates::fetch_template($r, 'show-selected')); - $r->print("

$title:\n"); + $io->print("

$title:\n"); my %newsettings = %$settings; if ($settings->{'all'} == 0) { - $r->print($sel); + $io->print($sel); } else { $newsettings{'all'} = 0; - Sesse::pr0n::Common::print_link($r, $sel, "/$event/", \%newsettings, $defsettings); + Sesse::pr0n::Common::print_link($io, $sel, "/$event/", \%newsettings, $defsettings); } - $r->print(' '); + $io->print(' '); if ($settings->{'all'} == 1) { - $r->print($all); + $io->print($all); } else { $newsettings{'all'} = 1; - Sesse::pr0n::Common::print_link($r, $all, "/$event/", \%newsettings, $defsettings); + Sesse::pr0n::Common::print_link($io, $all, "/$event/", \%newsettings, $defsettings); } - $r->print('

'); + $io->print('

'); } sub print_fullscreen { - my ($r, $event, $settings, $defsettings) = @_; + my ($r, $io, $event, $settings, $defsettings) = @_; chomp (my $title = Sesse::pr0n::Templates::fetch_template($r, 'fullscreen')); my %newsettings = %$settings; $newsettings{'fullscreen'} = 1; - $r->print("

"); - Sesse::pr0n::Common::print_link($r, $title, "/$event/", \%newsettings, $defsettings); - $r->print("

\n"); + $io->print("

"); + Sesse::pr0n::Common::print_link($io, $title, "/$event/", \%newsettings, $defsettings); + $io->print("

\n"); } sub print_fullscreen_fromhere { - my ($r, $event, $settings, $defsettings, $start) = @_; + my ($r, $io, $event, $settings, $defsettings, $start) = @_; chomp (my $title = Sesse::pr0n::Templates::fetch_template($r, 'fullscreen-fromhere')); @@ -666,9 +669,9 @@ sub print_fullscreen_fromhere { $newsettings{'fullscreen'} = 1; $newsettings{'start'} = $start; - $r->print(" "); - Sesse::pr0n::Common::print_link($r, $title, "/$event/", \%newsettings, $defsettings); - $r->print("\n"); + $io->print(" "); + Sesse::pr0n::Common::print_link($io, $title, "/$event/", \%newsettings, $defsettings); + $io->print("\n"); } 1; diff --git a/perl/Sesse/pr0n/Listing.pm b/perl/Sesse/pr0n/Listing.pm index c8f93f2..9f75fef 100644 --- a/perl/Sesse/pr0n/Listing.pm +++ b/perl/Sesse/pr0n/Listing.pm @@ -10,40 +10,44 @@ sub handler { my $dbh = Sesse::pr0n::Common::get_dbh(); # Internal? (Ugly?) - if ($r->get_server_name =~ /internal/ || $r->get_server_name =~ /skoyen\.bilder\.knatten\.com/ || $r->get_server_name =~ /lia\.heimdal\.org/) { + if (Sesse::pr0n::Common::get_server_name($r) =~ /internal/ || + Sesse::pr0n::Common::get_server_name($r) =~ /skoyen\.bilder\.knatten\.com/ || + Sesse::pr0n::Common::get_server_name($r) =~ /lia\.heimdal\.org/) { my $user = Sesse::pr0n::Common::check_access($r); - if (!defined($user)) { - return Apache2::Const::OK; - } + return Sesse::pr0n::Common::generate_401($r) if (!defined($user)); } # Fix common error: pr0n.sesse.net/+foo -> pr0n.sesse.net/+foo/ - if ($r->uri !~ /\/$/) { - $r->headers_out->{'location'} = $r->uri . "/"; - return Apache2::Const::REDIRECT; + if ($r->path_info !~ /\/$/) { + my $res = Plack::Response->new(301); + $res->header('Location' => $r->path_info . "/"); + return $res; } + + my $res = Plack::Response->new(200); + my $io = IO::String->new; # find the last modification my $ref = $dbh->selectrow_hashref('SELECT EXTRACT(EPOCH FROM last_update) AS last_update FROM last_picture_cache WHERE vhost=? ORDER BY last_update DESC LIMIT 1', - undef, $r->get_server_name) - or error($r, "Could not find any events", 404, "File not found"); - $r->set_last_modified($ref->{'last_update'}); - $r->content_type('text/html; charset=utf-8'); + undef, Sesse::pr0n::Common::get_server_name($r)) + or return error($r, "Could not find any events", 404, "File not found"); + Sesse::pr0n::Common::set_last_modified($r, $ref->{'last_update'}); + $res->content_type('text/html; charset=utf-8'); - # If the client can use cache, do so - if ((my $rc = $r->meets_conditions) != Apache2::Const::OK) { - return $rc; - } + # # If the client can use cache, do so + # if ((my $rc = $r->meets_conditions) != Apache2::Const::OK) { + # return $rc; + # } - if ($r->uri =~ /^\/\+tags\/?/) { + if ($r->path_info =~ /^\/\+tags\/?/) { # Tag cloud my $q = $dbh->prepare('SELECT tag,COUNT(*) AS frequency FROM tags t JOIN images i ON t.image=i.id WHERE vhost=? GROUP BY tag ORDER BY COUNT(*) DESC LIMIT 75') - or dberror($r, "Couldn't list events"); - $q->execute($r->get_server_name) - or dberror($r, "Couldn't get events"); + or return dberror($r, "Couldn't list events"); + $q->execute(Sesse::pr0n::Common::get_server_name($r)) + or return dberror($r, "Couldn't get events"); - Sesse::pr0n::Common::header($r, Sesse::pr0n::Templates::fetch_template($r, 'tag-listing')); - Sesse::pr0n::Templates::print_template($r, 'mainmenu-tags'); + Sesse::pr0n::Common::header($r, $io, Sesse::pr0n::Templates::fetch_template($r, 'tag-listing')); + Sesse::pr0n::Templates::print_template($r, $io, 'mainmenu-tags'); my $cloud = HTML::TagCloud->new; @@ -55,8 +59,8 @@ sub handler { $cloud->add($html, "/+tags/$uri/", $ref->{'frequency'}); } - $r->print($cloud->html_and_css()); - Sesse::pr0n::Common::footer($r); + $io->print($cloud->html_and_css()); + Sesse::pr0n::Common::footer($r, $io); $q->finish(); } else { @@ -64,41 +68,43 @@ sub handler { # my $q = $dbh->prepare('SELECT t1.id,t1.date,t1.name FROM events t1 LEFT JOIN images t2 ON t1.id=t2.event WHERE t1.vhost=? GROUP BY t1.id,t1.date,t1.name ORDER BY COALESCE(MAX(t2.date),\'1970-01-01 00:00:00\'),t1.id') or # dberror($r, "Couldn't list events"); my $q = $dbh->prepare('SELECT event,date,name FROM events e JOIN last_picture_cache c USING (vhost,event) WHERE vhost=? ORDER BY last_picture DESC NULLS LAST') - or dberror($r, "Couldn't list events"); - $q->execute($r->get_server_name) - or dberror($r, "Couldn't get events"); + or return dberror($r, "Couldn't list events"); + $q->execute(Sesse::pr0n::Common::get_server_name($r)) + or return dberror($r, "Couldn't get events"); - Sesse::pr0n::Common::header($r, Sesse::pr0n::Templates::fetch_template($r, 'event-listing')); + Sesse::pr0n::Common::header($r, $io, Sesse::pr0n::Templates::fetch_template($r, 'event-listing')); # See if there are any tags related to this vhost my $ref = $dbh->selectrow_hashref('SELECT * FROM tags t JOIN images i ON t.image=i.id WHERE vhost=? LIMIT 1', - undef, $r->get_server_name); + undef, Sesse::pr0n::Common::get_server_name($r)); if (defined($ref)) { - Sesse::pr0n::Templates::print_template($r, 'mainmenu-events'); + Sesse::pr0n::Templates::print_template($r, $io, 'mainmenu-events'); } my $allcaption = Sesse::pr0n::Templates::fetch_template($r, 'all-event-title'); - $r->print(" \n"); + $io->print(" \n"); - $r->print(" \n"); + Sesse::pr0n::Common::footer($r, $io); $q->finish(); } - return Apache2::Const::OK; + $io->setpos(0); + $res->body($io); + return $res; } 1; diff --git a/perl/Sesse/pr0n/NewEvent.pm b/perl/Sesse/pr0n/NewEvent.pm index 2aac990..8f4d6ce 100644 --- a/perl/Sesse/pr0n/NewEvent.pm +++ b/perl/Sesse/pr0n/NewEvent.pm @@ -3,37 +3,37 @@ use strict; use warnings; use Sesse::pr0n::Common qw(error dberror); -use Apache2::Request; sub handler { my $r = shift; - my $apr = Apache2::Request->new($r); my $dbh = Sesse::pr0n::Common::get_dbh(); my $user = Sesse::pr0n::Common::check_access($r); - if (!defined($user)) { - return Apache2::Const::OK; - } + return Sesse::pr0n::Common::generate_401($r) if (!defined($user)); - Sesse::pr0n::Common::header($r, "Legger til ny hendelse"); + my $res = Plack::Response->new(200); + my $io = IO::String->new; + Sesse::pr0n::Common::header($r, $io, "Legger til ny hendelse"); - my $id = $apr->param('id'); - my $date = $apr->param('date'); - my $desc = $apr->param('desc'); + my $id = $r->param('id'); + my $date = Encode::decode_utf8($r->param('date')); + my $desc = Encode::decode_utf8($r->param('desc')); - my @errors = Sesse::pr0n::Common::add_new_event($r, $dbh, $id, $date, $desc); + my @errors = Sesse::pr0n::Common::add_new_event($r, $res, $dbh, $id, $date, $desc); if (scalar @errors > 0) { for my $err (@errors) { - $r->print("

Feil: $err

\n"); + $io->print("

Feil: $err

\n"); } - $r->print("

Rett opp i feilene over før du går videre.

\n"); + $io->print("

Rett opp i feilene over før du går videre.

\n"); } else { - $r->print("

Hendelsen '$id' lagt til.

"); + $io->print("

Hendelsen '$id' lagt til.

"); } - Sesse::pr0n::Common::footer($r); + Sesse::pr0n::Common::footer($r, $io); - return Apache2::Const::OK; + $io->setpos(0); + $res->body($io); + return $res; } 1; diff --git a/perl/Sesse/pr0n/Overload.pm b/perl/Sesse/pr0n/Overload.pm index 0adce7c..e36489d 100644 --- a/perl/Sesse/pr0n/Overload.pm +++ b/perl/Sesse/pr0n/Overload.pm @@ -22,7 +22,7 @@ sub is_in_overload { my $r = shift; # Manually set overload mode - if (lc($r->dir_config('OverloadMode')) eq 'on') { + if ($Sesse::pr0n::Config::overload_mode) { return 1; } @@ -31,8 +31,8 @@ sub is_in_overload { $in_overload = 0; } - my $enable_threshold = $r->dir_config('OverloadEnableThreshold') || 10.0; - my $disable_threshold = $r->dir_config('OverloadDisableThreshold') || 5.0; + my $enable_threshold = $Sesse::pr0n::Config::overload_enable_threshold // 10.0; + my $disable_threshold = $Sesse::pr0n::Config::overload_disable_threshold // 5.0; # Check if our load average estimate is more than a minute old if (!defined($last_update) || (time - $last_update) > 60) { @@ -48,17 +48,17 @@ sub is_in_overload { if ($in_overload) { if ($loadavg < $disable_threshold) { - $r->log->info("Current load average is $loadavg (threshold: $disable_threshold), leaving overload mode"); + Sesse::pr0n::Common::log_info($r, "Current load average is $loadavg (threshold: $disable_threshold), leaving overload mode"); $in_overload = 0; } else { - $r->log->warn("Current load average is $loadavg (threshold: $disable_threshold), staying in overload mode"); + Sesse::pr0n::Common::log_warn($r, "Current load average is $loadavg (threshold: $disable_threshold), staying in overload mode"); } } else { if ($loadavg > $enable_threshold) { - $r->log->warn("Current load average is $loadavg (threshold: $enable_threshold), entering overload mode"); + Sesse::pr0n::Common::log_warn($r, "Current load average is $loadavg (threshold: $enable_threshold), entering overload mode"); $in_overload = 1; } else { - $r->log->info("Current load average is $loadavg (threshold: $enable_threshold)"); + Sesse::pr0n::Common::log_info($r, "Current load average is $loadavg (threshold: $enable_threshold)"); } } } diff --git a/perl/Sesse/pr0n/QscaleProxy.pm b/perl/Sesse/pr0n/QscaleProxy.pm index 69d7c76..f626902 100644 --- a/perl/Sesse/pr0n/QscaleProxy.pm +++ b/perl/Sesse/pr0n/QscaleProxy.pm @@ -16,7 +16,7 @@ BEGIN { $has_qscale = 1; }; if ($@) { - Apache2::ServerUtil->server->log_error("Could not load the qscale module ($@); continuing with ImageMagick only."); + print STDERR "Could not load the qscale module ($@); continuing with ImageMagick only.\n"; } } diff --git a/perl/Sesse/pr0n/Rotate.pm b/perl/Sesse/pr0n/Rotate.pm index 80c2552..d5086ec 100644 --- a/perl/Sesse/pr0n/Rotate.pm +++ b/perl/Sesse/pr0n/Rotate.pm @@ -3,16 +3,12 @@ use strict; use warnings; use Sesse::pr0n::Common qw(error dberror); -use Apache2::Request; sub handler { my $r = shift; - my $apr = Apache2::Request->new($r); my $dbh = Sesse::pr0n::Common::get_dbh(); my ($user, $takenby) = Sesse::pr0n::Common::check_access($r); - if (!defined($user)) { - return Apache2::Const::OK; - } + return Sesse::pr0n::Common::generate_401($r) if (!defined($user)); # FIXME: People can rotate and delete across vhosts using this interface. # We should add some sanity checks. @@ -21,34 +17,37 @@ sub handler { Sesse::pr0n::Common::header($r, "Rotation/deletion results"); + my $res = Plack::Response->new(200); + my $io = IO::String->new; + { # Enable transactions and error raising temporarily local $dbh->{RaiseError} = 1; - my @params = $apr->param(); + my @params = $r->param(); my $key; for $key (@params) { local $dbh->{AutoCommit} = 0; # Rotation - if ($key =~ /^rot-(\d+)-(90|180|270)$/ && $apr->param($key) eq 'on') { + if ($key =~ /^rot-(\d+)-(90|180|270)$/ && $r->param($key) eq 'on') { my ($id, $rotval) = ($1,$2); my $fname = Sesse::pr0n::Common::get_disk_location($r, $id); push @to_purge, Sesse::pr0n::Common::get_all_cache_urls($r, $dbh, $id); (my $tmpfname = $fname) =~ s/\.jpg$/-tmp.jpg/; system("/usr/bin/jpegtran -rotate $rotval -copy all < '$fname' > '$tmpfname' && /bin/mv '$tmpfname' '$fname'") == 0 - or error($r, "Rotation of $id [/usr/bin/jpegtran -rotate $rotval -copy all < '$fname' > '$tmpfname' && /bin/mv '$tmpfname' '$fname'] failed: $!."); - $r->print("

Rotated image ID `$id' by $rotval degrees.

\n"); + or return error($r, "Rotation of $id [/usr/bin/jpegtran -rotate $rotval -copy all < '$fname' > '$tmpfname' && /bin/mv '$tmpfname' '$fname'] failed: $!."); + $io->print("

Rotated image ID `$id' by $rotval degrees.

\n"); if ($rotval == 90 || $rotval == 270) { my $q = $dbh->do('UPDATE images SET height=width,width=height WHERE id=?', undef, $id) - or dberror($r, "Size clear of $id failed"); + or return dberror($r, "Size clear of $id failed"); $dbh->do('UPDATE last_picture_cache SET last_update=CURRENT_TIMESTAMP WHERE (vhost,event)=( SELECT vhost,event FROM images WHERE id=? )', undef, $id) - or dberror($r, "Cache invalidation at $id failed"); + or return dberror($r, "Cache invalidation at $id failed"); } - } elsif ($key =~ /^del-(\d+)$/ && $apr->param($key) eq 'on') { + } elsif ($key =~ /^del-(\d+)$/ && $r->param($key) eq 'on') { my $id = $1; push @to_purge, Sesse::pr0n::Common::get_all_cache_urls($r, $dbh, $id); { @@ -66,25 +65,26 @@ sub handler { if ($@) { # Some error occurred, rollback and bomb out $dbh->rollback; - dberror($r, "Transaction aborted because $@"); + return dberror($r, "Transaction aborted because $@"); } } - $r->print("

Deleted image `$id'.

\n"); + $io->print("

Deleted image `$id'.

\n"); } } } - my $event = $apr->param('event'); - $dbh->do('UPDATE last_picture_cache SET last_update=CURRENT_TIMESTAMP WHERE vhost=? AND event=?', undef, $r->get_server_name, $event) - or dberror($r, "Cache invalidation failed"); + my $event = $r->param('event'); + $dbh->do('UPDATE last_picture_cache SET last_update=CURRENT_TIMESTAMP WHERE vhost=? AND event=?', undef, Sesse::pr0n::Common::get_server_name($r), $event) + or return dberror($r, "Cache invalidation failed"); push @to_purge, "/$event/"; push @to_purge, "/+all/"; - Sesse::pr0n::Common::purge_cache($r, @to_purge); - - Sesse::pr0n::Common::footer($r); + Sesse::pr0n::Common::purge_cache($r, $res, @to_purge); - return Apache2::Const::OK; + Sesse::pr0n::Common::footer($r, $io); + $io->setpos(0); + $res->body($io); + return $res; } 1; diff --git a/perl/Sesse/pr0n/Select.pm b/perl/Sesse/pr0n/Select.pm index 53dc8a0..9db9d7b 100644 --- a/perl/Sesse/pr0n/Select.pm +++ b/perl/Sesse/pr0n/Select.pm @@ -3,41 +3,41 @@ use strict; use warnings; use Sesse::pr0n::Common qw(error dberror); -use Apache2::Request; sub handler { my $r = shift; - my $apr = Apache2::Request->new($r); my $dbh = Sesse::pr0n::Common::get_dbh(); my ($user, $takenby) = Sesse::pr0n::Common::check_access($r); - if (!defined($user)) { - return Apache2::Const::OK; - } + return Sesse::pr0n::Common::generate_401($r) if (!defined($user)); - my $event = $apr->param('event'); + my $event = $r->param('event'); - Sesse::pr0n::Common::header($r, "Selection results"); + my $res = Plack::Response->new(200); + my $io = IO::String->new; + Sesse::pr0n::Common::header($r, $io, "Selection results"); { # Enable transactions and error raising temporarily local $dbh->{AutoCommit} = 0; local $dbh->{RaiseError} = 1; - my $filename = $apr->param('filename'); - my $selected = $apr->param('selected'); + my $filename = $r->param('filename'); + my $selected = $r->param('selected'); my $sql_selected = 'f'; if (!defined($selected) || $selected eq '1') { $sql_selected = 't'; } - $dbh->do('UPDATE images SET selected=? WHERE vhost=? AND event=? AND filename=?', undef, $sql_selected, $r->get_server_name, $event, $filename); + $dbh->do('UPDATE images SET selected=? WHERE vhost=? AND event=? AND filename=?', undef, $sql_selected, Sesse::pr0n::Common::get_server_name($r), $event, $filename); } - $dbh->do('UPDATE last_picture_cache SET last_update=CURRENT_TIMESTAMP WHERE vhost=? AND event=?', undef, $r->get_server_name, $event) - or dberror($r, "Cache invalidation failed"); - Sesse::pr0n::Common::purge_cache($r, "/$event/"); - Sesse::pr0n::Common::footer($r); + $dbh->do('UPDATE last_picture_cache SET last_update=CURRENT_TIMESTAMP WHERE vhost=? AND event=?', undef, Sesse::pr0n::Common::get_server_name($r), $event) + or return dberror($r, "Cache invalidation failed"); + Sesse::pr0n::Common::purge_cache($r, $res, "/$event/"); + Sesse::pr0n::Common::footer($r, $io); - return Apache2::Const::OK; + $io->setpos(0); + $res->body($io); + return $res; } 1; diff --git a/perl/Sesse/pr0n/Templates.pm b/perl/Sesse/pr0n/Templates.pm index 8bf0c1f..aac4058 100644 --- a/perl/Sesse/pr0n/Templates.pm +++ b/perl/Sesse/pr0n/Templates.pm @@ -18,7 +18,7 @@ our %dirs = (); sub update_dirs { my $r = shift; - my $base = $r->dir_config('TemplateBase'); + my $base = $Sesse::pr0n::Config::template_base; for my $dir (<$base/*>) { next unless -d $dir; @@ -36,7 +36,7 @@ sub r_to_dir { update_dirs($r); } - my $site = $r->get_server_name(); + my $site = Sesse::pr0n::Common::get_server_name($r); if (defined($dirs{$site})) { return $site; } else { @@ -55,7 +55,7 @@ sub fetch_template { my $newcache = {}; - my $base = $r->dir_config('TemplateBase'); + my $base = $Sesse::pr0n::Config::template_base; open TEMPLATE, "<$base/$dir/$template" or ($dir ne 'default' and open TEMPLATE, "<$base/default/$template") or Sesse::pr0n::Common::error($r, "Couldn't open $dir/$template: $!"); @@ -84,8 +84,8 @@ sub process_template { } sub print_template { - my ($r, $template, $args) = @_; - $r->print(process_template($r, $template, $args)); + my ($r, $io, $template, $args) = @_; + $io->print(process_template($r, $template, $args)); } 1; diff --git a/perl/Sesse/pr0n/WebDAV.pm b/perl/Sesse/pr0n/WebDAV.pm index 3f89645..84abaca 100644 --- a/perl/Sesse/pr0n/WebDAV.pm +++ b/perl/Sesse/pr0n/WebDAV.pm @@ -5,53 +5,46 @@ use warnings; use Sesse::pr0n::Common qw(error dberror); use Digest::SHA; use MIME::Base64; -use Apache2::Request; -use Apache2::Upload; sub handler { my $r = shift; my $dbh = Sesse::pr0n::Common::get_dbh(); - - $r->headers_out->{'DAV'} = "1,2"; + + my $res = Plack::Response->new(200); + my $io = IO::String->new; + $r->header('DAV' => "1,2"); # We only handle depth=0, depth=1 (cf. the RFC) - my $depth = $r->headers_in->{'depth'}; + my $depth = $r->header('depth'); $depth = 0 if (!defined($depth)); if (defined($depth) && $depth ne "0" && $depth ne "1") { - $r->content_type('text/plain; charset="utf-8"'); - $r->status(403); - $r->print("Invalid depth setting"); - return Apache2::Const::OK; - } - - my ($user,$takenby) = Sesse::pr0n::Common::check_access($r); - if (!defined($user)) { - return Apache2::Const::OK; + $res->status(403); + $res->content_type('text/plain; charset="utf-8"'); + $res->body("Invalid depth setting"); + return $res; } # Just "ping, are you alive and do you speak WebDAV" if ($r->method eq "OPTIONS") { - $r->content_type('text/plain; charset="utf-8"'); - $r->status(200); - $r->headers_out->{'allow'} = 'OPTIONS,PUT'; - $r->headers_out->{'ms-author-via'} = 'DAV'; - return Apache2::Const::OK; + $res->content_type('text/plain; charset="utf-8"'); + $res->header('allow' => 'OPTIONS,PUT'); + $res->header('ms-author-via' => 'DAV'); + return $res; } + my ($user,$takenby) = Sesse::pr0n::Common::check_access($r); + return Sesse::pr0n::Common::generate_401($r) if (!defined($user)); + # Directory listings et al if ($r->method eq "PROPFIND") { - # We ignore the body, but we _must_ consume it fully before - # we output anything, or Squid will get seriously confused - $r->discard_request_body; - - $r->content_type('text/xml; charset="utf-8"'); - $r->status(207); + $res->content_type('text/xml; charset="utf-8"'); + $res->status(207); - if ($r->uri =~ m#^/webdav/?$#) { - $r->headers_out->{'content-location'} = "/webdav/"; + if ($r->path_info =~ m#^/webdav/?$#) { + $res->header('content-location' => "/webdav/"); # Root directory - $r->print(<<"EOF"); + $io->print(<<"EOF"); @@ -68,7 +61,7 @@ EOF # Optionally list the upload/ dir if ($depth >= 1) { - $r->print(<<"EOF"); + $io->print(<<"EOF"); /webdav/upload/ @@ -81,12 +74,12 @@ EOF EOF } - $r->print("\n"); - } elsif ($r->uri =~ m#^/webdav/upload/?$#) { - $r->headers_out->{'content-location'} = "/webdav/upload/"; + $io->print("\n"); + } elsif ($r->path_info =~ m#^/webdav/upload/?$#) { + $res->header('content-location' => "/webdav/upload/"); # Upload root directory - $r->print(<<"EOF"); + $io->print(<<"EOF"); @@ -104,16 +97,16 @@ EOF # Optionally list all events if ($depth >= 1) { my $q = $dbh->prepare('SELECT * FROM events WHERE vhost=?') or - dberror($r, "Couldn't list events"); - $q->execute($r->get_server_name) or - dberror($r, "Couldn't get events"); + return dberror($r, "Couldn't list events"); + $q->execute(Sesse::pr0n::Common::get_server_name($r)) or + return dberror($r, "Couldn't get events"); while (my $ref = $q->fetchrow_hashref()) { - my $id = $ref->{'event'}; - my $name = $ref->{'name'}; + my $id = Encode::encode_utf8($ref->{'event'}); + my $name = Encode::encode_utf8($ref->{'name'}); $name =~ s/&/\&/g; # hack :-) - $r->print(<<"EOF"); + $io->print(<<"EOF"); /webdav/upload/$id/ @@ -130,24 +123,24 @@ EOF $q->finish; } - $r->print("\n"); - } elsif ($r->uri =~ m#^/webdav/upload/([a-zA-Z0-9-]+)/?$#) { + $io->print("\n"); + } elsif ($r->path_info =~ m#^/webdav/upload/([a-zA-Z0-9-]+)/?$#) { my $event = $1; - $r->headers_out->{'content-location'} = "/webdav/upload/$event/"; + $res->header('content-location' => "/webdav/upload/$event/"); # Check that we do indeed exist my $ref = $dbh->selectrow_hashref('SELECT count(*) AS numev FROM events WHERE vhost=? AND event=?', - undef, $r->get_server_name, $event); + undef, Sesse::pr0n::Common::get_server_name($r), $event); if ($ref->{'numev'} != 1) { - $r->status(404); - $r->content_type('text/plain; charset=utf-8'); - $r->print("Couldn't find event in database"); - return Apache2::Const::OK; + $res->status(404); + $res->content_type('text/plain; charset=utf-8'); + $res->body("Couldn't find event in database"); + return $res; } # OK, list the directory - $r->print(<<"EOF"); + $io->print(<<"EOF"); @@ -165,9 +158,9 @@ EOF # List all the files within too, of course :-) if ($depth >= 1) { my $q = $dbh->prepare('SELECT * FROM images WHERE vhost=? AND event=?') or - dberror($r, "Couldn't list images"); - $q->execute($r->get_server_name, $event) or - dberror($r, "Couldn't get events"); + return dberror($r, "Couldn't list images"); + $q->execute(Sesse::pr0n::Common::get_server_name($r), $event) or + return dberror($r, "Couldn't get events"); while (my $ref = $q->fetchrow_hashref()) { my $id = $ref->{'id'}; @@ -178,7 +171,7 @@ EOF $mtime = POSIX::strftime("%a, %d %b %Y %H:%M:%S GMT", gmtime($mtime)); my $mime_type = Sesse::pr0n::Common::get_mimetype_from_filename($filename); - $r->print(<<"EOF"); + $io->print(<<"EOF"); /webdav/upload/$event/$filename @@ -196,7 +189,7 @@ EOF $q->finish; # And the magical autorename folder - $r->print(<<"EOF"); + $io->print(<<"EOF"); /webdav/upload/$event/autorename/ @@ -210,27 +203,28 @@ EOF EOF } - $r->print("\n"); - - return Apache2::Const::OK; - } elsif ($r->uri =~ m#^/webdav/upload/([a-zA-Z0-9-]+)/autorename/?$#) { + $io->print("\n"); + $io->setpos(0); + $res->body($io); + return $res; + } elsif ($r->path_info =~ m#^/webdav/upload/([a-zA-Z0-9-]+)/autorename/?$#) { # The autorename folder is always empty my $event = $1; - $r->headers_out->{'content-location'} = "/webdav/upload/$event/autorename/"; + $res->header('content-location' => "/webdav/upload/$event/autorename/"); # Check that we do indeed exist my $ref = $dbh->selectrow_hashref('SELECT count(*) AS numev FROM events WHERE vhost=? AND event=?', - undef, $r->get_server_name, $event); + undef, Sesse::pr0n::Common::get_server_name($r), $event); if ($ref->{'numev'} != 1) { - $r->status(404); - $r->content_type('text/plain; charset=utf-8'); - $r->print("Couldn't find event in database"); - return Apache2::Const::OK; + $res->status(404); + $res->content_type('text/plain; charset=utf-8'); + $res->body("Couldn't find event in database"); + return $res; } # OK, list the (empty) directory - $r->print(<<"EOF"); + $res->body(<<"EOF"); @@ -246,15 +240,15 @@ EOF EOF - return Apache2::Const::OK; - } elsif ($r->uri =~ m#^/webdav/upload/([a-zA-Z0-9-]+)/([a-zA-Z0-9._()-]+)$#) { + return $res; + } elsif ($r->path_info =~ m#^/webdav/upload/([a-zA-Z0-9-]+)/([a-zA-Z0-9._()-]+)$#) { # stat a single file my ($event, $filename) = ($1, $2); my ($fname, $size, $mtime); # check if we have a pending fake file for this my $ref = $dbh->selectrow_hashref('SELECT count(*) AS numfiles FROM fake_files WHERE event=? AND vhost=? AND filename=? AND expires_at > now()', - undef, $event, $r->get_server_name, $filename); + undef, $event, Sesse::pr0n::Common::get_server_name($r), $filename); if ($ref->{'numfiles'} == 1) { $fname = "/dev/null"; $size = 0; @@ -264,15 +258,15 @@ EOF } if (!defined($fname)) { - $r->status(404); - $r->content_type('text/plain; charset=utf-8'); - $r->print("Couldn't find file"); - return Apache2::Const::OK; + $res->status(404); + $res->content_type('text/plain; charset=utf-8'); + $res->body("Couldn't find file"); + return $res; } my $mime_type = Sesse::pr0n::Common::get_mimetype_from_filename($filename); $mtime = POSIX::strftime("%a, %d %b %Y %H:%M:%S GMT", gmtime($mtime)); - $r->print(<<"EOF"); + $res->body(<<"EOF"); @@ -289,15 +283,15 @@ EOF EOF - return Apache2::Const::OK; - } elsif ($r->uri =~ m#^/webdav/upload/([a-zA-Z0-9-]+)/autorename/(.{1,250})$#) { + return $res; + } elsif ($r->path_info =~ m#^/webdav/upload/([a-zA-Z0-9-]+)/autorename/(.{1,250})$#) { # stat a single file in autorename my ($event, $filename) = ($1, $2); my ($fname, $size, $mtime); # check if we have a pending fake file for this my $ref = $dbh->selectrow_hashref('SELECT count(*) AS numfiles FROM fake_files WHERE event=? AND vhost=? AND filename=? AND expires_at > now()', - undef, $event, $r->get_server_name, $filename); + undef, $event, Sesse::pr0n::Common::get_server_name($r), $filename); if ($ref->{'numfiles'} == 1) { $fname = "/dev/null"; $size = 0; @@ -305,22 +299,22 @@ EOF } else { # check if we have a "shadow file" for this my $ref = $dbh->selectrow_hashref('SELECT id FROM shadow_files WHERE vhost=? AND event=? AND filename=? AND expires_at > now()', - undef, $r->get_server_name, $event, $filename); + undef, Sesse::pr0n::Common::get_server_name($r), $event, $filename); if (defined($ref)) { ($fname, $size, $mtime) = Sesse::pr0n::Common::stat_image_from_id($r, $ref->{'id'}); } } if (!defined($fname)) { - $r->status(404); - $r->content_type('text/plain; charset=utf-8'); - $r->print("Couldn't find file"); - return Apache2::Const::OK; + $res->status(404); + $res->content_type('text/plain; charset=utf-8'); + $res->body("Couldn't find file"); + return $res; } my $mime_type = Sesse::pr0n::Common::get_mimetype_from_filename($filename); $mtime = POSIX::strftime("%a, %d %b %Y %H:%M:%S GMT", gmtime($mtime)); - $r->print(<<"EOF"); + $io->print(<<"EOF"); @@ -338,19 +332,22 @@ EOF EOF } else { - $r->status(404); - $r->content_type('text/plain; charset=utf-8'); - $r->print("Couldn't find file"); + $res->status(404); + $res->content_type('text/plain; charset=utf-8'); + $res->body("Couldn't find file"); + return $res; } - return Apache2::Const::OK; + $io->setpos(0); + $res->body($io); + return $res; } if ($r->method eq "HEAD" or $r->method eq "GET") { - if ($r->uri !~ m#^/webdav/upload/([a-zA-Z0-9-]+)/(autorename/)?(.{1,250})$#) { - $r->status(404); - $r->content_type('text/xml; charset=utf-8'); - $r->print("\n

Couldn't find file

"); - return Apache2::Const::OK; + if ($r->path_info !~ m#^/webdav/upload/([a-zA-Z0-9-]+)/(autorename/)?(.{1,250})$#) { + $res->status(404); + $res->content_type('text/xml; charset=utf-8'); + $res->body("\n

Couldn't find file

"); + return $res; } my ($event, $autorename, $filename) = ($1, $2, $3); @@ -360,7 +357,7 @@ EOF # check if we have a pending fake file for this my $ref = $dbh->selectrow_hashref('SELECT count(*) AS numfiles FROM fake_files WHERE event=? AND vhost=? AND filename=? AND expires_at > now()', - undef, $event, $r->get_server_name, $filename); + undef, $event, Sesse::pr0n::Common::get_server_name($r), $filename); if ($ref->{'numfiles'} == 1) { $fname = "/dev/null"; $size = 0; @@ -369,7 +366,7 @@ EOF # check if we have a "shadow file" for this if (defined($autorename) && $autorename eq "autorename/") { my $ref = $dbh->selectrow_hashref('SELECT id FROM shadow_files WHERE vhost=? AND event=? AND filename=? AND expires_at > now()', - undef, $r->get_server_name, $event, $filename); + undef, Sesse::pr0n::Common::get_server_name($r), $event, $filename); if (defined($ref)) { ($fname, $size, $mtime) = Sesse::pr0n::Common::stat_image_from_id($r, $ref->{'id'}); } @@ -379,34 +376,34 @@ EOF } if (!defined($fname)) { - $r->status(404); - $r->content_type('text/plain; charset=utf-8'); - $r->print("Couldn't find file"); - return Apache2::Const::OK; + $res->status(404); + $res->content_type('text/plain; charset=utf-8'); + $res->body("Couldn't find file"); + return $res; } - $r->status(200); - $r->set_content_length($size); - $r->set_last_modified($mtime); + $res->status(200); + $res->set_content_length($size); + Sesse::pr0n::Common::set_last_modified($res, $mtime); if ($r->method eq "GET") { - $r->sendfile($fname); + $res->content(IO::File::WithPath->new($fname)); } - return Apache2::Const::OK; + return $res; } if ($r->method eq "PUT") { - if ($r->uri !~ m#^/webdav/upload/([a-zA-Z0-9-]+)/(autorename/)?(.{1,250})$#) { - $r->status(403); - $r->content_type('text/plain; charset=utf-8'); - $r->print("No access"); - return Apache2::Const::OK; + if ($r->path_info !~ m#^/webdav/upload/([a-zA-Z0-9-]+)/(autorename/)?(.{1,250})$#) { + $res->status(403); + $res->content_type('text/plain; charset=utf-8'); + $res->body("No access"); + return $res; } my ($event, $autorename, $filename) = ($1, $2, $3); - my $size = $r->headers_in->{'content-length'}; + my $size = $r->header('content-length'); if (!defined($size)) { - $size = $r->headers_in->{'x-expected-entity-length'}; + $size = $r->header('x-expected-entity-length'); } my $orig_filename = $filename; @@ -415,10 +412,10 @@ EOF if (defined($autorename) && $autorename eq "autorename/") { $filename =~ tr/a-zA-Z0-9.()-/_/c; } else { - $r->status(403); - $r->content_type('text/plain; charset=utf-8'); - $r->print("Illegal characters in filename"); - return Apache2::Const::OK; + $res->status(403); + $res->content_type('text/plain; charset=utf-8'); + $res->body("Illegal characters in filename"); + return $res; } } @@ -428,38 +425,38 @@ EOF # if ($size == 0 || $filename =~ /^\.(_|DS_Store)/) { $dbh->do('DELETE FROM fake_files WHERE expires_at <= now() OR (event=? AND vhost=? AND filename=?);', - undef, $event, $r->get_server_name, $filename) - or dberror($r, "Couldn't prune fake_files"); + undef, $event, Sesse::pr0n::Common::get_server_name($r), $filename) + or return dberror($r, "Couldn't prune fake_files"); $dbh->do('INSERT INTO fake_files (vhost,event,filename,expires_at) VALUES (?,?,?,now() + interval \'1 day\');', - undef, $r->get_server_name, $event, $filename) - or dberror($r, "Couldn't add file"); - $r->content_type('text/plain; charset="utf-8"'); - $r->status(201); - $r->print("OK"); - $r->log->info("Fake upload of $event/$filename"); - return Apache2::Const::OK; + undef, Sesse::pr0n::Common::get_server_name($r), $event, $filename) + or return dberror($r, "Couldn't add file"); + $res->content_type('text/plain; charset="utf-8"'); + $res->status(201); + $res->body("OK"); + Sesse::pr0n::Common::log_info($r, "Fake upload of $event/$filename"); + return $res; } # Get the new ID my $ref = $dbh->selectrow_hashref("SELECT NEXTVAL('imageid_seq') AS id;"); my $newid = $ref->{'id'}; if (!defined($newid)) { - dberror($r, "Couldn't get new ID"); + return dberror($r, "Couldn't get new ID"); } # Autorename if we need to $ref = $dbh->selectrow_hashref("SELECT COUNT(*) AS numfiles FROM images WHERE vhost=? AND event=? AND filename=?", - undef, $r->get_server_name, $event, $filename) - or dberror($r, "Couldn't check for existing files"); + undef, Sesse::pr0n::Common::get_server_name($r), $event, $filename) + or return dberror($r, "Couldn't check for existing files"); if ($ref->{'numfiles'} > 0) { if (defined($autorename) && $autorename eq "autorename/") { - $r->log->info("Renaming $filename to $newid.jpeg"); + Sesse::pr0n::Common::log_info($r, "Renaming $filename to $newid.jpeg"); $filename = "$newid.jpeg"; } else { - $r->status(403); - $r->content_type('text/plain; charset=utf-8'); - $r->print("File $filename already exists in event $event, cannot overwrite"); - return Apache2::Const::OK; + $res->status(403); + $res->content_type('text/plain; charset=utf-8'); + $res->body("File $filename already exists in event $event, cannot overwrite"); + return $res; } } @@ -472,23 +469,19 @@ EOF # Try to insert this new file eval { $dbh->do('DELETE FROM fake_files WHERE vhost=? AND event=? AND filename=?', - undef, $r->get_server_name, $event, $filename); + undef, Sesse::pr0n::Common::get_server_name($r), $event, $filename); $dbh->do('INSERT INTO images (id,vhost,event,uploadedby,takenby,filename) VALUES (?,?,?,?,?,?)', - undef, $newid, $r->get_server_name, $event, $user, $takenby, $filename); - Sesse::pr0n::Common::purge_cache($r, "/$event/"); + undef, $newid, Sesse::pr0n::Common::get_server_name($r), $event, $user, $takenby, $filename); + Sesse::pr0n::Common::purge_cache($r, $res, "/$event/"); # Now save the file to disk Sesse::pr0n::Common::ensure_disk_location_exists($r, $newid); $fname = Sesse::pr0n::Common::get_disk_location($r, $newid); - open NEWFILE, ">$fname" - or die "$fname: $!"; - - my $buf; - if ($r->read($buf, $size)) { - print NEWFILE $buf or die "write($fname): $!"; - } + open NEWFILE, ">", $fname + or die "$fname: $!"; + print NEWFILE $r->content; close NEWFILE or die "close($fname): $!"; # Orient stuff correctly @@ -506,51 +499,50 @@ EOF # OK, we got this far, commit $dbh->commit; - $r->log->notice("Successfully wrote $event/$filename to $fname"); + Sesse::pr0n::Common::log_info($r, "Successfully wrote $event/$filename to $fname"); }; if ($@) { # Some error occurred, rollback and bomb out $dbh->rollback; - error($r, "Transaction aborted because $@"); unlink($fname); + return error($r, "Transaction aborted because $@"); } } # Insert a `shadow file' we can stat the next day or so if (defined($autorename) && $autorename eq "autorename/") { $dbh->do('DELETE FROM shadow_files WHERE expires_at <= now() OR (vhost=? AND event=? AND filename=?);', - undef, $r->get_server_name, $event, $filename) - or dberror($r, "Couldn't prune shadow_files"); + undef, Sesse::pr0n::Common::get_server_name($r), $event, $filename) + or return dberror($r, "Couldn't prune shadow_files"); $dbh->do('INSERT INTO shadow_files (vhost,event,filename,id,expires_at) VALUES (?,?,?,?,now() + interval \'1 day\');', - undef, $r->get_server_name, $event, $orig_filename, $newid) - or dberror($r, "Couldn't add shadow file"); - $r->log->info("Added shadow entry for $event/$filename"); + undef, Sesse::pr0n::Common::get_server_name($r), $event, $orig_filename, $newid) + or return dberror($r, "Couldn't add shadow file"); + Sesse::pr0n::Common::log_info($r, "Added shadow entry for $event/$filename"); } - $r->content_type('text/plain; charset="utf-8"'); - $r->status(201); - $r->print("OK"); - - return Apache2::Const::OK; + $res->content_type('text/plain; charset="utf-8"'); + $res->status(201); + $res->body("OK"); + return $res; } # Yes, we fake locks. :-) if ($r->method eq "LOCK") { - if ($r->uri !~ m#^/webdav/upload/([a-zA-Z0-9-]+)/(autorename/)?([a-zA-Z0-9._-]+)$#) { - $r->status(403); - $r->content_type('text/plain; charset=utf-8'); - $r->print("No access"); - return Apache2::Const::OK; + if ($r->path_info !~ m#^/webdav/upload/([a-zA-Z0-9-]+)/(autorename/)?([a-zA-Z0-9._-]+)$#) { + $res->status(403); + $res->content_type('text/plain; charset=utf-8'); + $res->body("No access"); + return $res; } my ($event, $autorename, $filename) = ($1, $2, $3); $autorename = '' if (!defined($autorename)); my $sha1 = Digest::SHA::sha1_base64("/$event/$autorename$filename"); - $r->status(200); - $r->content_type('text/xml; charset=utf-8'); + $res->status(200); + $res->content_type('text/xml; charset=utf-8'); - $r->print(<<"EOF"); + $io->print(<<"EOF"); @@ -569,38 +561,39 @@ EOF EOF - return Apache2::Const::OK; + $io->setpos(0); + $res->body($io); + return $res; } if ($r->method eq "UNLOCK") { - $r->content_type('text/plain; charset="utf-8"'); - $r->status(200); - $r->print("OK"); - - return Apache2::Const::OK; + $res->content_type('text/plain; charset="utf-8"'); + $res->status(200); + $res->body("OK"); + return $res; } if ($r->method eq "DELETE") { - if ($r->uri !~ m#^/webdav/upload/([a-zA-Z0-9-]+)/(autorename/)?(\._[a-zA-Z0-9._-]+)$#) { - $r->status(403); - $r->content_type('text/plain; charset=utf-8'); - $r->print("No access"); - return Apache2::Const::OK; + if ($r->path_info !~ m#^/webdav/upload/([a-zA-Z0-9-]+)/(autorename/)?(\._[a-zA-Z0-9._-]+)$#) { + $res->status(403); + $res->content_type('text/plain; charset=utf-8'); + $res->body("No access"); + return $res; } my ($event, $autorename, $filename) = ($1, $2, $3); $dbh->do('DELETE FROM images WHERE vhost=? AND event=? AND filename=?', - undef, $r->get_server_name, $event, $filename) - or dberror($r, "Couldn't remove file"); + undef, Sesse::pr0n::Common::get_server_name($r), $event, $filename) + or return dberror($r, "Couldn't remove file"); $dbh->do('UPDATE last_picture_cache SET last_update=CURRENT_TIMESTAMP WHERE vhost=? AND event=?', - undef, $r->get_server_name, $event) - or dberror($r, "Couldn't invalidate cache"); - $r->status(200); - $r->print("OK"); + undef, Sesse::pr0n::Common::get_server_name($r), $event) + or return dberror($r, "Couldn't invalidate cache"); + $res->status(200); + $res->body("OK"); - $r->log->info("deleted $event/$filename"); + Sesse::pr0n::Common::log_info($r, "deleted $event/$filename"); - return Apache2::Const::OK; + return $res; } if ($r->method eq "MOVE" or @@ -608,18 +601,17 @@ EOF $r->method eq "RMCOL" or $r->method eq "RENAME" or $r->method eq "COPY") { - $r->content_type('text/plain; charset="utf-8"'); - $r->status(403); - $r->print("Sorry, you do not have access to that feature."); - return Apache2::Const::OK; + $res->content_type('text/plain; charset="utf-8"'); + $res->status(403); + $res->body("Sorry, you do not have access to that feature."); + return $res; } - $r->content_type('text/plain; charset=utf-8'); - $r->log->error("unknown method " . $r->method); - $r->status(500); - $r->print("Unknown method"); - - return Apache2::Const::OK; + $res->content_type('text/plain; charset=utf-8'); + Sesse::pr0n::Common::log_error($r, "unknown method " . $r->method); + $res->status(500); + $res->body("Unknown method"); + return $res; } 1; diff --git a/perl/Sesse/pr0n/pr0n.pm b/perl/Sesse/pr0n/pr0n.pm index 9391398..bddfe22 100644 --- a/perl/Sesse/pr0n/pr0n.pm +++ b/perl/Sesse/pr0n/pr0n.pm @@ -6,6 +6,7 @@ use Sesse::pr0n::Rotate; use Sesse::pr0n::Select; use Sesse::pr0n::WebDAV; use Sesse::pr0n::NewEvent; +use IO::File::WithPath; package Sesse::pr0n::pr0n; use strict; @@ -14,7 +15,7 @@ use warnings; sub handler { my $r = shift; - my $uri = $r->uri; + my $uri = $r->path_info; if ($uri eq '/' || $uri =~ /^\/\+tags\/?$/) { return Sesse::pr0n::Listing::handler($r); } elsif ($uri eq '/robots.txt' || @@ -33,29 +34,32 @@ sub handler { $uri eq '/pr0n.ico' || $uri =~ m#^/usage/([a-zA-Z0-9_.]+)$#) { $uri =~ s#^/##; - my $fname = Sesse::pr0n::Common::get_base($r) . 'files/' . $uri; + my $fname = $Sesse::pr0n::Config::image_base . 'files/' . $uri; my (undef, undef, undef, undef, undef, undef, undef, $size, undef, $mtime) = stat($fname) or error($r, "stat of $fname: $!"); - $r->content_type(Sesse::pr0n::Common::get_mimetype_from_filename($uri)); - $r->set_content_length($size); - $r->set_last_modified($mtime); + my $res = Plack::Response->new(200); + $res->content_type(Sesse::pr0n::Common::get_mimetype_from_filename($uri)); + $res->content_length($size); + Sesse::pr0n::Common::set_last_modified($res, $mtime); - if((my $rc = $r->meets_conditions) != Apache2::Const::OK) { - return $rc; - } + #if((my $rc = $r->meets_conditions) != Apache2::Const::OK) { + # return $rc; + #} - $r->sendfile(Sesse::pr0n::Common::get_base($r) . 'files/' . $uri); - return Apache2::Const::OK; + $res->content(IO::File::WithPath->new($Sesse::pr0n::Config::image_base . 'files/' . $uri)); + return $res; } elsif ($uri eq '/newevent.html') { - $r->content_type('text/html; charset=utf-8'); - $r->sendfile(Sesse::pr0n::Common::get_base($r) . "files/newevent.html"); - return Apache2::Const::OK; + my $res = Plack::Response->new(200); + $res->content_type('text/html; charset=utf-8'); + $res->content(IO::File::WithPath->new($Sesse::pr0n::Config::image_base . 'files/newevent.html')); + return $res; } elsif ($uri =~ m#^/webdav#) { return Sesse::pr0n::WebDAV::handler($r); } elsif ($uri =~ m#^/usage/([a-zA-Z0-9.-]+)$#) { - $r->sendfile(Sesse::pr0n::Common::get_base($r) . "usage/$1"); - return Apache2::Const::OK; + my $res = Plack::Response->new(200); + $res->content(IO::File::WithPath->new($Sesse::pr0n::Config::image_base . "usage/$1")); + return $res; } elsif ($uri =~ m#^/rotate$#) { return Sesse::pr0n::Rotate::handler($r); } elsif ($uri =~ m#^/select$#) { @@ -70,11 +74,14 @@ sub handler { return Sesse::pr0n::Image::handler($r); } - $r->status(404); - Sesse::pr0n::Common::header($r, "404 File Not Found"); - $r->print("

The file you requested was not found.

"); - Sesse::pr0n::Common::footer($r); - return Apache2::Const::OK; + my $res = Plack::Response->new(404); + my $io = IO::String->new; + Sesse::pr0n::Common::header($r, $io, "404 File Not Found"); + $io->print("

The file you requested was not found.

"); + Sesse::pr0n::Common::footer($r, $io); + $io->setpos(0); + $res->body($io); + return $res; } 1; diff --git a/perl/mkpasswd.pl b/perl/mkpasswd.pl new file mode 100755 index 0000000..5d6aac3 --- /dev/null +++ b/perl/mkpasswd.pl @@ -0,0 +1,24 @@ +#! /usr/bin/perl + + +use lib qw(.); +use Term::ReadKey; +use strict; +use warnings; + +use Sesse::pr0n::Config; +eval { + require Sesse::pr0n::Config_local; +}; +use Sesse::pr0n::Common; + +Term::ReadKey::ReadMode(2); +print STDERR "Enter password: "; +chomp (my $pass = ); +print STDERR "\n"; +Term::ReadKey::ReadMode(0); + +my $salt = Sesse::pr0n::Common::get_pseudorandom_bytes(16); # Doesn't need to be cryptographically secur. +my $hash = "\$2a\$07\$" . Crypt::Eksblowfish::Bcrypt::en_base64($salt); +print Crypt::Eksblowfish::Bcrypt::bcrypt($pass, $hash), "\n"; + diff --git a/perl/pr0n.psgi b/perl/pr0n.psgi new file mode 100644 index 0000000..6a015dc --- /dev/null +++ b/perl/pr0n.psgi @@ -0,0 +1,16 @@ +#! /usr/bin/perl + +use strict; +use warnings; +use lib qw(.); + +use Plack::Request; +use Plack::Response; +use Sesse::pr0n::pr0n; + +sub { + my $env = shift; + my $req = Plack::Request->new($env); + my $res = Sesse::pr0n::pr0n::handler($req); + return $res->finalize; +} diff --git a/pr0n.service b/pr0n.service new file mode 100644 index 0000000..a3f207e --- /dev/null +++ b/pr0n.service @@ -0,0 +1,12 @@ +[Unit] +Description=pr0n app server +After=network.target + +[Service] +ExecStart=/usr/bin/start_server --port=127.0.0.1:5015 -- plackup -I/srv/pr0n.sesse.net/perl -s Starlet /srv/pr0n.sesse.net/perl/pr0n.psgi +Type=simple +Restart=on-failure +ExecReload=/bin/kill -HUP $MAINPID + +[Install] +WantedBy=multi-user.target