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 ~ "."'
-<VirtualHost *:8008>
- 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
- <Location />
- SetHandler modperl
- PerlResponseHandler Sesse::pr0n::pr0n
- </Location>
-</VirtualHost>
-
-<VirtualHost *:443>
- 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
- <Location />
- SetHandler modperl
- PerlResponseHandler Sesse::pr0n::pr0n
- </Location>
-</VirtualHost>
-
-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.)
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
<p>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 <a href="http://www.apache.org/">Apache</a> 2.4,
- <a href="http://perl.apache.org/">mod_perl</a> 2.0,
- <a href="http://www.imagemagick.org/">ImageMagick</a> 6.x
+ course.) pr0n itself is a custom-made system by myself,
+ a <a href="http://search.cpan.org/~miyagawa/PSGI-1.102/PSGI.pod">PSGI</a>
+ app server running under <a href="http://search.cpan.org/dist/Starlet/">Starlet</a>
+ behind <a href="https://www.varnish-cache.org/">Varnish</a> 4.1,
+ using <a href="http://www.imagemagick.org/">ImageMagick</a> 6.x
(as well as various other Perl modules) and
<a href="http://git.sesse.net/?p=qscale">qscale</a>, using
<a href="http://www.postgresql.org/">PostgreSQL</a> 9.4 as the back-end
on IRC as Sesse on EFnet, IRCnet, Freenode or OFTC.</p>
<hr />
- <p class="footer">pr0n v2.81,
+ <p class="footer">pr0n v3.00-pre,
© 2004–2015 <a href="http://www.sesse.net/">Steinar H. Gunderson</a>.</p>
</body>
</html>
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;
require Sesse::pr0n::Config_local;
};
- $VERSION = "v2.81";
+ $VERSION = "v3.00-pre";
@ISA = qw(Exporter);
@EXPORT = qw(&error &dberror);
%EXPORT_TAGS = qw();
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;
$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(" <p>Error: $err</p>\n");
- footer($r);
+ header($r, $io, $title);
+ $io->print(" <p>Error: $err</p>\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 });
}
}
sub print_link {
- my ($r, $title, $baseurl, $param, $defparam, $accesskey) = @_;
+ my ($io, $title, $baseurl, $param, $defparam, $accesskey) = @_;
my $str = "<a href=\"$baseurl" . get_query_string($param, $defparam) . "\"";
if (defined($accesskey) && length($accesskey) == 1) {
$str .= " accesskey=\"$accesskey\"";
}
$str .= ">$title</a>";
- $r->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;
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 {
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";
}
}
}
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";
}
}
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 {
#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 {
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'});
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.
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);
} 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(
}
if ($err) {
- $r->log->warn("$physical_fname: $err");
+ log_warn($r, "$physical_fname: $err");
$err =~ /(\d+)/;
if ($1 >= 400) {
undef $magick;
# 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');
}
}
$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');
}
($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 = ();
# 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);
}
}
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-]+)$/) {
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 ();
}
# 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;
}
$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.
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$/) {
} 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;
# 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;
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;
# 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;
$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;
# 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'};
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;
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;
$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;
}
# 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
# 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.
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;
}
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 = ();
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'},
});
} 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
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 = ();
$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'}));
# 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");
}
}
# Print out all thumbnails
if ($rot == 1) {
- $r->print(" <form method=\"post\" action=\"/rotate\">\n");
- $r->print(" <input type=\"hidden\" name=\"event\" value=\"$event\" />\n");
+ $io->print(" <form method=\"post\" action=\"/rotate\">\n");
+ $io->print(" <input type=\"hidden\" name=\"event\" value=\"$event\" />\n");
}
while (my $ref = $q->fetchrow_hashref()) {
my $groupkey = $takenby . $day;
if ($groupkey ne $lastupl) {
- $r->print(" </p>\n\n") if ($lastupl ne "" && $rot != 1);
+ $io->print(" </p>\n\n") if ($lastupl ne "" && $rot != 1);
$lastupl = $groupkey;
my %newsettings = %settings;
my $url = "/$event/" . Sesse::pr0n::Common::get_query_string(\%newsettings, \%defsettings);
- $r->print(" <h2>");
- 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("</h2>\n");
+ $io->print(" <h2>");
+ 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("</h2>\n");
if ($rot != 1) {
- $r->print(" <p class=\"photos\">\n");
+ $io->print(" <p class=\"photos\">\n");
}
}
}
if ($rot == 1) {
- $r->print(" <p>");
+ $io->print(" <p>");
} else {
- $r->print(" ");
+ $io->print(" ");
}
- $r->print("<a href=\"$prefix$uri\"><img src=\"$prefix${thumbxres}x${thumbyres}/$filename\" alt=\"\"$imgsz /></a>\n");
+ $io->print("<a href=\"$prefix$uri\"><img src=\"$prefix${thumbxres}x${thumbyres}/$filename\" alt=\"\"$imgsz /></a>\n");
if ($rot == 1) {
- $r->print(" 90 <input type=\"checkbox\" name=\"rot-" .
+ $io->print(" 90 <input type=\"checkbox\" name=\"rot-" .
$ref->{'id'} . "-90\" />\n");
- $r->print(" 180 <input type=\"checkbox\" name=\"rot-" .
+ $io->print(" 180 <input type=\"checkbox\" name=\"rot-" .
$ref->{'id'} . "-180\" />\n");
- $r->print(" 270 <input type=\"checkbox\" name=\"rot-" .
+ $io->print(" 270 <input type=\"checkbox\" name=\"rot-" .
$ref->{'id'} . "-270\" />\n");
- $r->print(" " .
+ $io->print(" " .
" Del <input type=\"checkbox\" name=\"del-" . $ref->{'id'} . "\" /></p>\n");
}
}
if ($rot == 1) {
- $r->print(" <input type=\"submit\" value=\"Rotate\" />\n");
- $r->print(" </form>\n");
+ $io->print(" <input type=\"submit\" value=\"Rotate\" />\n");
+ $io->print(" </form>\n");
} else {
- $r->print(" </p>\n");
+ $io->print(" </p>\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 {
}
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(" <p>$title:\n");
+ $io->print(" <p>$title:\n");
for my $a (@$alternatives) {
my $text;
$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(" </p>\n");
+ $io->print(" </p>\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(" <p>$title:\n");
+ $io->print(" <p>$title:\n");
# Get choices
chomp (my $unlimited = Sesse::pr0n::Templates::fetch_template($r, 'imgsperpage-unlimited'));
$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(" </p>\n");
+ $io->print(" </p>\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(" <p>$title:\n");
+ $io->print(" <p>$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('</p>');
+ $io->print('</p>');
}
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();
# 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);
$end = $num_images;
}
- $r->print(" <p class=\"nextprev\">\n");
+ $io->print(" <p class=\"nextprev\">\n");
# Previous
if ($start > 1) {
$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) {
$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(" </p>\n");
+ $io->print(" </p>\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(" <p>$title:\n");
+ $io->print(" <p>$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('</p>');
+ $io->print('</p>');
}
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(" <p>");
- Sesse::pr0n::Common::print_link($r, $title, "/$event/", \%newsettings, $defsettings);
- $r->print("</p>\n");
+ $io->print(" <p>");
+ Sesse::pr0n::Common::print_link($io, $title, "/$event/", \%newsettings, $defsettings);
+ $io->print("</p>\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'));
$newsettings{'fullscreen'} = 1;
$newsettings{'start'} = $start;
- $r->print(" <span class=\"fsfromhere\">");
- Sesse::pr0n::Common::print_link($r, $title, "/$event/", \%newsettings, $defsettings);
- $r->print("</span>\n");
+ $io->print(" <span class=\"fsfromhere\">");
+ Sesse::pr0n::Common::print_link($io, $title, "/$event/", \%newsettings, $defsettings);
+ $io->print("</span>\n");
}
1;
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;
$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 {
# 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(" <ul>\n");
- $r->print(" <li><a href=\"+all/\">$allcaption</a></li>\n");
- $r->print(" </ul>\n");
+ $io->print(" <ul>\n");
+ $io->print(" <li><a href=\"+all/\">$allcaption</a></li>\n");
+ $io->print(" </ul>\n");
- $r->print(" <ul>\n");
+ $io->print(" <ul>\n");
while (my $ref = $q->fetchrow_hashref()) {
my $id = $ref->{'event'};
my $date = HTML::Entities::encode_entities($ref->{'date'});
my $name = HTML::Entities::encode_entities($ref->{'name'});
- $r->print(" <li><a href=\"$id/\">$name</a> ($date)</li>\n");
+ $io->print(" <li><a href=\"$id/\">$name</a> ($date)</li>\n");
}
- $r->print(" </ul>\n");
- Sesse::pr0n::Common::footer($r);
+ $io->print(" </ul>\n");
+ Sesse::pr0n::Common::footer($r, $io);
$q->finish();
}
- return Apache2::Const::OK;
+ $io->setpos(0);
+ $res->body($io);
+ return $res;
}
1;
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(" <p>Feil: $err</p>\n");
+ $io->print(" <p>Feil: $err</p>\n");
}
- $r->print(" <p>Rett opp i feilene over før du går videre.</p>\n");
+ $io->print(" <p>Rett opp i feilene over før du går videre.</p>\n");
} else {
- $r->print(" <p>Hendelsen '$id' lagt til.</p>");
+ $io->print(" <p>Hendelsen '$id' lagt til.</p>");
}
- Sesse::pr0n::Common::footer($r);
+ Sesse::pr0n::Common::footer($r, $io);
- return Apache2::Const::OK;
+ $io->setpos(0);
+ $res->body($io);
+ return $res;
}
1;
my $r = shift;
# Manually set overload mode
- if (lc($r->dir_config('OverloadMode')) eq 'on') {
+ if ($Sesse::pr0n::Config::overload_mode) {
return 1;
}
$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) {
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)");
}
}
}
$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";
}
}
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.
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(" <p>Rotated image ID `$id' by $rotval degrees.</p>\n");
+ or return error($r, "Rotation of $id [/usr/bin/jpegtran -rotate $rotval -copy all < '$fname' > '$tmpfname' && /bin/mv '$tmpfname' '$fname'] failed: $!.");
+ $io->print(" <p>Rotated image ID `$id' by $rotval degrees.</p>\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);
{
if ($@) {
# Some error occurred, rollback and bomb out
$dbh->rollback;
- dberror($r, "Transaction aborted because $@");
+ return dberror($r, "Transaction aborted because $@");
}
}
- $r->print(" <p>Deleted image `$id'.</p>\n");
+ $io->print(" <p>Deleted image `$id'.</p>\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;
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;
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;
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 {
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: $!");
}
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;
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");
<?xml version="1.0" encoding="utf-8"?>
<multistatus xmlns="DAV:">
<response>
# Optionally list the upload/ dir
if ($depth >= 1) {
- $r->print(<<"EOF");
+ $io->print(<<"EOF");
<response>
<href>/webdav/upload/</href>
<propstat>
</response>
EOF
}
- $r->print("</multistatus>\n");
- } elsif ($r->uri =~ m#^/webdav/upload/?$#) {
- $r->headers_out->{'content-location'} = "/webdav/upload/";
+ $io->print("</multistatus>\n");
+ } elsif ($r->path_info =~ m#^/webdav/upload/?$#) {
+ $res->header('content-location' => "/webdav/upload/");
# Upload root directory
- $r->print(<<"EOF");
+ $io->print(<<"EOF");
<?xml version="1.0" encoding="utf-8"?>
<multistatus xmlns="DAV:">
<response>
# 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");
<response>
<href>/webdav/upload/$id/</href>
<propstat>
$q->finish;
}
- $r->print("</multistatus>\n");
- } elsif ($r->uri =~ m#^/webdav/upload/([a-zA-Z0-9-]+)/?$#) {
+ $io->print("</multistatus>\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");
<?xml version="1.0" encoding="utf-8"?>
<multistatus xmlns="DAV:">
<response>
# 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'};
$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");
<response>
<href>/webdav/upload/$event/$filename</href>
<propstat>
$q->finish;
# And the magical autorename folder
- $r->print(<<"EOF");
+ $io->print(<<"EOF");
<response>
<href>/webdav/upload/$event/autorename/</href>
<propstat>
EOF
}
- $r->print("</multistatus>\n");
-
- return Apache2::Const::OK;
- } elsif ($r->uri =~ m#^/webdav/upload/([a-zA-Z0-9-]+)/autorename/?$#) {
+ $io->print("</multistatus>\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");
<?xml version="1.0" encoding="utf-8"?>
<multistatus xmlns="DAV:">
<response>
</multistatus>
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;
}
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");
<?xml version="1.0" encoding="utf-8"?>
<multistatus xmlns="DAV:">
<response>
</response>
</multistatus>
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;
} 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");
<?xml version="1.0" encoding="utf-8"?>
<multistatus xmlns="DAV:">
<response>
</multistatus>
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("<?xml version=\"1.0\"?>\n<p>Couldn't find file</p>");
- 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("<?xml version=\"1.0\"?>\n<p>Couldn't find file</p>");
+ return $res;
}
my ($event, $autorename, $filename) = ($1, $2, $3);
# 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;
# 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'});
}
}
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;
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;
}
}
#
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;
}
}
# 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
# 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");
<?xml version="1.0" encoding="utf-8"?>
<prop xmlns="DAV:">
<lockdiscovery>
</lockdiscovery>
</prop>
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
$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;
use Sesse::pr0n::Select;
use Sesse::pr0n::WebDAV;
use Sesse::pr0n::NewEvent;
+use IO::File::WithPath;
package Sesse::pr0n::pr0n;
use strict;
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' ||
$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$#) {
return Sesse::pr0n::Image::handler($r);
}
- $r->status(404);
- Sesse::pr0n::Common::header($r, "404 File Not Found");
- $r->print(" <p>The file you requested was not found.</p>");
- 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(" <p>The file you requested was not found.</p>");
+ Sesse::pr0n::Common::footer($r, $io);
+ $io->setpos(0);
+ $res->body($io);
+ return $res;
}
1;
--- /dev/null
+#! /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 = <STDIN>);
+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";
+
--- /dev/null
+#! /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;
+}
--- /dev/null
+[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