From 2d6536cab108c937e2af49f7dcf15f2230f44d1a Mon Sep 17 00:00:00 2001
From: "Steinar H. Gunderson"
Date: Sun, 23 Jul 2006 17:43:57 +0200
Subject: [PATCH] Initial checkin.
---
faq.html | 140 ++++
newevent.html | 23 +
perl/Sesse/pr0n/Common.pm | 503 +++++++++++++++
perl/Sesse/pr0n/Image.pm | 85 +++
perl/Sesse/pr0n/Index.pm | 454 +++++++++++++
perl/Sesse/pr0n/Listing.pm | 49 ++
perl/Sesse/pr0n/NewEvent.pm | 55 ++
perl/Sesse/pr0n/Overload.pm | 70 ++
perl/Sesse/pr0n/Rotate.pm | 69 ++
perl/Sesse/pr0n/Select.pm | 47 ++
perl/Sesse/pr0n/Single.pm | 64 ++
perl/Sesse/pr0n/Templates.pm | 87 +++
perl/Sesse/pr0n/WebDAV.pm | 606 ++++++++++++++++++
perl/Sesse/pr0n/pr0n.pm | 63 ++
pr0n.css | 19 +
robots.txt | 2 +
skoyen.css | 50 ++
templates/bilder.knatten.com/date | 3 +
templates/bilder.knatten.com/event-listing | 1 +
templates/bilder.knatten.com/footer | 8 +
templates/bilder.knatten.com/header | 21 +
templates/bilder.knatten.com/imgsperpage | 1 +
.../bilder.knatten.com/imgsperpage-unlimited | 1 +
templates/bilder.knatten.com/infobox | 1 +
templates/bilder.knatten.com/infobox-off | 1 +
templates/bilder.knatten.com/infobox-on | 1 +
templates/bilder.knatten.com/nextpage | 1 +
templates/bilder.knatten.com/overloadmode | 4 +
templates/bilder.knatten.com/prevpage | 1 +
templates/bilder.knatten.com/show | 1 +
templates/bilder.knatten.com/show-all | 1 +
templates/bilder.knatten.com/show-selected | 1 +
templates/bilder.knatten.com/submittedby | 1 +
templates/bilder.knatten.com/thispage | 1 +
templates/bilder.knatten.com/thumbsize | 1 +
templates/bilder.knatten.com/viewres | 1 +
.../bilder.knatten.com/viewres-unlimited | 1 +
templates/default/date | 3 +
templates/default/event-listing | 1 +
templates/default/footer | 8 +
templates/default/header | 13 +
templates/default/imgsperpage | 1 +
templates/default/imgsperpage-unlimited | 1 +
templates/default/infobox | 1 +
templates/default/infobox-off | 1 +
templates/default/infobox-on | 1 +
templates/default/nextpage | 1 +
templates/default/overloadmode | 6 +
templates/default/prevpage | 1 +
templates/default/show | 1 +
templates/default/show-all | 1 +
templates/default/show-selected | 1 +
templates/default/submittedby | 1 +
templates/default/thispage | 1 +
templates/default/thumbsize | 1 +
templates/default/viewres | 1 +
templates/default/viewres-unlimited | 1 +
templates/images.tg05.gathering.org/date | 3 +
.../images.tg05.gathering.org/event-listing | 1 +
templates/images.tg05.gathering.org/footer | 15 +
templates/images.tg05.gathering.org/header | 59 ++
.../images.tg05.gathering.org/imgsperpage | 1 +
.../imgsperpage-unlimited | 1 +
templates/images.tg05.gathering.org/infobox | 1 +
.../images.tg05.gathering.org/infobox-off | 1 +
.../images.tg05.gathering.org/infobox-on | 1 +
templates/images.tg05.gathering.org/nextpage | 1 +
.../images.tg05.gathering.org/overloadmode | 6 +
templates/images.tg05.gathering.org/prevpage | 1 +
templates/images.tg05.gathering.org/show | 1 +
templates/images.tg05.gathering.org/show-all | 1 +
.../images.tg05.gathering.org/show-selected | 1 +
.../images.tg05.gathering.org/submittedby | 1 +
templates/images.tg05.gathering.org/thispage | 1 +
templates/images.tg05.gathering.org/thumbsize | 1 +
templates/images.tg05.gathering.org/viewres | 1 +
.../viewres-unlimited | 1 +
templates/itk-bilder.samfundet.no/date | 3 +
.../itk-bilder.samfundet.no/event-listing | 1 +
templates/itk-bilder.samfundet.no/footer | 12 +
templates/itk-bilder.samfundet.no/header | 56 ++
templates/itk-bilder.samfundet.no/imgsperpage | 1 +
.../imgsperpage-unlimited | 1 +
templates/itk-bilder.samfundet.no/infobox | 1 +
templates/itk-bilder.samfundet.no/infobox-off | 1 +
templates/itk-bilder.samfundet.no/infobox-on | 1 +
templates/itk-bilder.samfundet.no/nextpage | 1 +
.../itk-bilder.samfundet.no/overloadmode | 4 +
templates/itk-bilder.samfundet.no/prevpage | 1 +
templates/itk-bilder.samfundet.no/show | 1 +
templates/itk-bilder.samfundet.no/show-all | 1 +
.../itk-bilder.samfundet.no/show-selected | 1 +
templates/itk-bilder.samfundet.no/submittedby | 1 +
templates/itk-bilder.samfundet.no/thispage | 1 +
templates/itk-bilder.samfundet.no/thumbsize | 1 +
templates/itk-bilder.samfundet.no/viewres | 1 +
.../itk-bilder.samfundet.no/viewres-unlimited | 1 +
templates/skoyen.bilder.knatten.com/date | 3 +
.../skoyen.bilder.knatten.com/event-listing | 1 +
templates/skoyen.bilder.knatten.com/footer | 8 +
templates/skoyen.bilder.knatten.com/header | 13 +
.../skoyen.bilder.knatten.com/imgsperpage | 1 +
.../imgsperpage-unlimited | 1 +
templates/skoyen.bilder.knatten.com/infobox | 1 +
.../skoyen.bilder.knatten.com/infobox-off | 1 +
.../skoyen.bilder.knatten.com/infobox-on | 1 +
templates/skoyen.bilder.knatten.com/nextpage | 1 +
.../skoyen.bilder.knatten.com/overloadmode | 4 +
templates/skoyen.bilder.knatten.com/prevpage | 1 +
templates/skoyen.bilder.knatten.com/show | 1 +
templates/skoyen.bilder.knatten.com/show-all | 1 +
.../skoyen.bilder.knatten.com/show-selected | 1 +
.../skoyen.bilder.knatten.com/submittedby | 1 +
templates/skoyen.bilder.knatten.com/thispage | 1 +
templates/skoyen.bilder.knatten.com/thumbsize | 1 +
templates/skoyen.bilder.knatten.com/viewres | 1 +
.../viewres-unlimited | 1 +
117 files changed, 2718 insertions(+)
create mode 100644 faq.html
create mode 100644 newevent.html
create mode 100644 perl/Sesse/pr0n/Common.pm
create mode 100644 perl/Sesse/pr0n/Image.pm
create mode 100644 perl/Sesse/pr0n/Index.pm
create mode 100644 perl/Sesse/pr0n/Listing.pm
create mode 100644 perl/Sesse/pr0n/NewEvent.pm
create mode 100644 perl/Sesse/pr0n/Overload.pm
create mode 100644 perl/Sesse/pr0n/Rotate.pm
create mode 100644 perl/Sesse/pr0n/Select.pm
create mode 100644 perl/Sesse/pr0n/Single.pm
create mode 100644 perl/Sesse/pr0n/Templates.pm
create mode 100644 perl/Sesse/pr0n/WebDAV.pm
create mode 100644 perl/Sesse/pr0n/pr0n.pm
create mode 100644 pr0n.css
create mode 100644 robots.txt
create mode 100644 skoyen.css
create mode 100644 templates/bilder.knatten.com/date
create mode 100644 templates/bilder.knatten.com/event-listing
create mode 100644 templates/bilder.knatten.com/footer
create mode 100644 templates/bilder.knatten.com/header
create mode 100644 templates/bilder.knatten.com/imgsperpage
create mode 100644 templates/bilder.knatten.com/imgsperpage-unlimited
create mode 100644 templates/bilder.knatten.com/infobox
create mode 100644 templates/bilder.knatten.com/infobox-off
create mode 100644 templates/bilder.knatten.com/infobox-on
create mode 100644 templates/bilder.knatten.com/nextpage
create mode 100644 templates/bilder.knatten.com/overloadmode
create mode 100644 templates/bilder.knatten.com/prevpage
create mode 100644 templates/bilder.knatten.com/show
create mode 100644 templates/bilder.knatten.com/show-all
create mode 100644 templates/bilder.knatten.com/show-selected
create mode 100644 templates/bilder.knatten.com/submittedby
create mode 100644 templates/bilder.knatten.com/thispage
create mode 100644 templates/bilder.knatten.com/thumbsize
create mode 100644 templates/bilder.knatten.com/viewres
create mode 100644 templates/bilder.knatten.com/viewres-unlimited
create mode 100644 templates/default/date
create mode 100644 templates/default/event-listing
create mode 100644 templates/default/footer
create mode 100644 templates/default/header
create mode 100644 templates/default/imgsperpage
create mode 100644 templates/default/imgsperpage-unlimited
create mode 100644 templates/default/infobox
create mode 100644 templates/default/infobox-off
create mode 100644 templates/default/infobox-on
create mode 100644 templates/default/nextpage
create mode 100644 templates/default/overloadmode
create mode 100644 templates/default/prevpage
create mode 100644 templates/default/show
create mode 100644 templates/default/show-all
create mode 100644 templates/default/show-selected
create mode 100644 templates/default/submittedby
create mode 100644 templates/default/thispage
create mode 100644 templates/default/thumbsize
create mode 100644 templates/default/viewres
create mode 100644 templates/default/viewres-unlimited
create mode 100644 templates/images.tg05.gathering.org/date
create mode 100644 templates/images.tg05.gathering.org/event-listing
create mode 100644 templates/images.tg05.gathering.org/footer
create mode 100644 templates/images.tg05.gathering.org/header
create mode 100644 templates/images.tg05.gathering.org/imgsperpage
create mode 100644 templates/images.tg05.gathering.org/imgsperpage-unlimited
create mode 100644 templates/images.tg05.gathering.org/infobox
create mode 100644 templates/images.tg05.gathering.org/infobox-off
create mode 100644 templates/images.tg05.gathering.org/infobox-on
create mode 100644 templates/images.tg05.gathering.org/nextpage
create mode 100644 templates/images.tg05.gathering.org/overloadmode
create mode 100644 templates/images.tg05.gathering.org/prevpage
create mode 100644 templates/images.tg05.gathering.org/show
create mode 100644 templates/images.tg05.gathering.org/show-all
create mode 100644 templates/images.tg05.gathering.org/show-selected
create mode 100644 templates/images.tg05.gathering.org/submittedby
create mode 100644 templates/images.tg05.gathering.org/thispage
create mode 100644 templates/images.tg05.gathering.org/thumbsize
create mode 100644 templates/images.tg05.gathering.org/viewres
create mode 100644 templates/images.tg05.gathering.org/viewres-unlimited
create mode 100644 templates/itk-bilder.samfundet.no/date
create mode 100644 templates/itk-bilder.samfundet.no/event-listing
create mode 100644 templates/itk-bilder.samfundet.no/footer
create mode 100644 templates/itk-bilder.samfundet.no/header
create mode 100644 templates/itk-bilder.samfundet.no/imgsperpage
create mode 100644 templates/itk-bilder.samfundet.no/imgsperpage-unlimited
create mode 100644 templates/itk-bilder.samfundet.no/infobox
create mode 100644 templates/itk-bilder.samfundet.no/infobox-off
create mode 100644 templates/itk-bilder.samfundet.no/infobox-on
create mode 100644 templates/itk-bilder.samfundet.no/nextpage
create mode 100644 templates/itk-bilder.samfundet.no/overloadmode
create mode 100644 templates/itk-bilder.samfundet.no/prevpage
create mode 100644 templates/itk-bilder.samfundet.no/show
create mode 100644 templates/itk-bilder.samfundet.no/show-all
create mode 100644 templates/itk-bilder.samfundet.no/show-selected
create mode 100644 templates/itk-bilder.samfundet.no/submittedby
create mode 100644 templates/itk-bilder.samfundet.no/thispage
create mode 100644 templates/itk-bilder.samfundet.no/thumbsize
create mode 100644 templates/itk-bilder.samfundet.no/viewres
create mode 100644 templates/itk-bilder.samfundet.no/viewres-unlimited
create mode 100644 templates/skoyen.bilder.knatten.com/date
create mode 100644 templates/skoyen.bilder.knatten.com/event-listing
create mode 100644 templates/skoyen.bilder.knatten.com/footer
create mode 100644 templates/skoyen.bilder.knatten.com/header
create mode 100644 templates/skoyen.bilder.knatten.com/imgsperpage
create mode 100644 templates/skoyen.bilder.knatten.com/imgsperpage-unlimited
create mode 100644 templates/skoyen.bilder.knatten.com/infobox
create mode 100644 templates/skoyen.bilder.knatten.com/infobox-off
create mode 100644 templates/skoyen.bilder.knatten.com/infobox-on
create mode 100644 templates/skoyen.bilder.knatten.com/nextpage
create mode 100644 templates/skoyen.bilder.knatten.com/overloadmode
create mode 100644 templates/skoyen.bilder.knatten.com/prevpage
create mode 100644 templates/skoyen.bilder.knatten.com/show
create mode 100644 templates/skoyen.bilder.knatten.com/show-all
create mode 100644 templates/skoyen.bilder.knatten.com/show-selected
create mode 100644 templates/skoyen.bilder.knatten.com/submittedby
create mode 100644 templates/skoyen.bilder.knatten.com/thispage
create mode 100644 templates/skoyen.bilder.knatten.com/thumbsize
create mode 100644 templates/skoyen.bilder.knatten.com/viewres
create mode 100644 templates/skoyen.bilder.knatten.com/viewres-unlimited
diff --git a/faq.html b/faq.html
new file mode 100644
index 0000000..3ad0efe
--- /dev/null
+++ b/faq.html
@@ -0,0 +1,140 @@
+
+
+
+
+ pr0n FAQ
+
+
+
+ pr0n FAQ
+ Last updated July 16th, 2006
+
+ So, what is this pr0n thing anyway?
+
+ pr0n is my very own gallery system. It is used on a few different
+ host names, most notably at pr0n.sesse.net
+ to show images I and others have taken at events I care about (some
+ more than others, of course).
+
+ Why the name? Is this some kind of fetish site?
+
+ The name "pr0n" (scriptkiddie-speak for "porn", of course) was just seen
+ as a very good fit for an image gallery. :-) There is no (and will not
+ be any) adult content on this site.
+
+ Can I upload my own images here?
+
+ Yes, you can, as long as they're related to one of the events already
+ here. Contact me (see the bottom of the page) for more information.
+
+ Can I download all the pictures for viewing?
+
+ Sorry, no. First of all, please don't use any "web mirroring" program to
+ download all the images -- of course, I can't stop you, but you're
+ putting a lot of unneccessary load on the system. There are two main
+ reasons for not downloading all the pictures: First, there is a
+ question of copyright; not all images here are taken by me, and I've
+ been given permission to display them here, not to pass them on. Second,
+ keep in mind that some of the events contain over 2GB of images --
+ do you really need all that? I'd advise you to crank up the thumbnail
+ size to the maximum possible size instead; it's quite comfortable to
+ browse images on without having to click back and forth all the time.
+
+ I just changed thumbnail resolution, why is everything so slow?
+
+ Probably the requested size was never generated before, so the server
+ has to scale all the images. As the scaling method used is geared
+ towards getting good-quality, sharp thumbnails, not speed, this can
+ take a while. It's all getting cached on disk for later re-use, though,
+ so the next time somebody views the same images in that resolution,
+ it will be snappy as usual.
+
+ Why didn't you just throw up Gallery?
+
+ Because it didn't fit my needs, and the same goes for all other systems
+ I've seen. I wanted something no-nonsense that would work for my
+ purposes -- I don't want to click around endlessly just to watch some
+ pictures. Others are of course free to do as they wish, I can't impose
+ my will on anybody :-)
+
+ What are the primary features of pr0n?
+
+ Mostly that it's no-nonsense and just works, without being in your way.
+ Also, it has dynamical rescaling (of good quality -- proper,
+ sharp thumbnails, no crappy nearest-neighbor scaling) of both thumbnails
+ and images (most client-side scaling sucks quality-wise, unfortunately),
+ an easy-to-use WebDAV -based upload
+ interface and in general good performance (being a set of persistent,
+ optimized Perl modules; I've seen it throw out over 300 hits a second,
+ but I won't guarantee it would withstand a Slashdot attack ;-) ). Also,
+ it has quite OK skinning capabilities, so it's able to adapt into
+ different designs quite easily.
+
+ What hardware/software does it run on?
+
+ pr0n currently runs on an Athlon 64 X2 3800+ with 2GB RAM and ordinary
+ SATA disks. (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.0, mod_perl 2.0 and ImageMagick 6.x (as well as various
+ other Perl modules), using PostgreSQL 8.1 as the back-end
+ database for metadata et al. The base operating system is Debian etch (ie. âtestingâ).
+
+ The Perl modules aren't really that big -- we're talking about only
+ approx. 1500 lines of code (of which ~30% is the WebDAV part; I should
+ really make that a bit cleaner once). Most of the real work is done by
+ the software on which pr0n builds on.
+
+ How much data is there in there, anyway?
+
+ At the time of writing, approximately 44GB of image data (that is, over
+ 35000 different images), plus cache, plus metadata in the SQL database.
+ (These numbers are growing rather rapidly, so they could be outdated at
+ any given time.)
+
+ Can I get the source?
+
+ Probably, but are you sure you can get it to work? It's
+ non-trivial to set up, as it depends on pre-release software and a lot of
+ custom configuring; this is not a pre-made, user friendly package for your
+ favourite Linux distribution. You can probably get a tarball, but I'm not
+ going to hold your hand configuring it. :-) If you really want to try,
+ contact me (see the bottom of the page) and we'll see what we can do.
+
+ Will you implement feature X?
+
+ Probably not; I have a lot of things to do besides programming new
+ features. Also, I'm not really sure if I want tons of stupid people
+ writing stupid comments under my images, or icky HTML pages with
+ "previous" and "next" buttons instead of just getting directly to
+ the images :-) If you really have a novel or cool feature, feel
+ free to contact me (see below).
+
+ Is the upload WebDAV server RFC-compliant?
+
+ Unfortunately, no. When and if somebody makes a sane framework for
+ making WebDAV servers I can use, it probably will, but ATM it's just
+ too much work for what I need it for. It would be a lot easier if
+ I only had to support WebDAV level 1, but due to silly restrictions
+ in Mac OS X' WebDAV client I have to support WebDAV level 2 as well,
+ and, well, most of that is faked. ;-) In addition, there are multiple
+ minor features in the system (like autorenaming files on name clashes)
+ that just aren't easy to adapt to WebDAV. The WebDAV service is
+ restricted, though, so I guess rather few people will get hurt just
+ because I'm not fully compliant ;-)
+
+ How do I get in touch with you?
+
+ Try e-mail , or reach me
+ on IRC as Sesse on EFnet, IRCnet, Freenode or OFTC.
+
+
+
+
+
diff --git a/newevent.html b/newevent.html
new file mode 100644
index 0000000..f74e672
--- /dev/null
+++ b/newevent.html
@@ -0,0 +1,23 @@
+
+
+
+
+ Ny hendelse
+
+
+
+ Ny hendelse
+
+ Merk at du ikke kan fjerne hendelser når de først er lagt til; hvis du
+ har gjort noe feil må du snakke med Steinar. :-)
+
+
+
+
diff --git a/perl/Sesse/pr0n/Common.pm b/perl/Sesse/pr0n/Common.pm
new file mode 100644
index 0000000..f915260
--- /dev/null
+++ b/perl/Sesse/pr0n/Common.pm
@@ -0,0 +1,503 @@
+package Sesse::pr0n::Common;
+use strict;
+use warnings;
+
+use Sesse::pr0n::Templates;
+use Sesse::pr0n::Overload;
+
+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 DBI;
+use DBD::Pg;
+use Image::Magick;
+use POSIX;
+use Digest::SHA1;
+use MIME::Base64;
+use MIME::Types;
+use LWP::Simple;
+# use Image::Info;
+use Image::ExifTool;
+
+BEGIN {
+ use Exporter ();
+ our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
+
+ $VERSION = "v2.04";
+ @ISA = qw(Exporter);
+ @EXPORT = qw(&error &dberror);
+ %EXPORT_TAGS = qw();
+ @EXPORT_OK = qw(&error &dberror);
+
+ our $dbh = DBI->connect("dbi:Pg:dbname=pr0n;host=127.0.0.1", "pr0n", "EsVdwImY")
+ or die "Couldn't connect to PostgreSQL database: " . DBI->errstr;
+ our $mimetypes = new MIME::Types;
+
+ Apache2::ServerUtil->server->log_error("Initializing pr0n $VERSION");
+}
+END {
+ our $dbh;
+ $dbh->disconnect;
+}
+
+our ($dbh, $mimetypes);
+
+sub error {
+ my ($r,$err,$status,$title) = @_;
+
+ if (!defined($status) || !defined($title)) {
+ $status = 500;
+ $title = "Internal server error";
+ }
+
+ $r->content_type('text/html; charset=utf-8');
+ $r->status($status);
+
+ header($r, $title);
+ $r->print(" Error: $err
\n");
+ footer($r);
+
+ $r->log->error($err);
+
+ ModPerl::Util::exit();
+}
+
+sub dberror {
+ my ($r,$err) = @_;
+ error($r, "$err (DB error: " . $dbh->errstr . ")");
+}
+
+sub header {
+ my ($r,$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') {
+ $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 });
+}
+
+sub footer {
+ my ($r) = @_;
+ Sesse::pr0n::Templates::print_template($r, "footer",
+ { version => $Sesse::pr0n::Common::VERSION });
+}
+
+sub scale_aspect {
+ my ($width, $height, $thumbxres, $thumbyres) = @_;
+
+ unless ($thumbxres >= $width &&
+ $thumbyres >= $height) {
+ my $sfh = $width / $thumbxres;
+ my $sfv = $height / $thumbyres;
+ if ($sfh > $sfv) {
+ $width /= $sfh;
+ $height /= $sfh;
+ } else {
+ $width /= $sfv;
+ $height /= $sfv;
+ }
+ $width = POSIX::floor($width);
+ $height = POSIX::floor($height);
+ }
+
+ return ($width, $height);
+}
+
+sub print_link {
+ my ($r, $title, $baseurl, $param, $defparam) = @_;
+ my $str = "{$key}) && $value == $defparam->{$key});
+
+ $str .= ($first) ? "?" : '&';
+ $str .= "$key=$value";
+ $first = 0;
+ }
+
+ $str .= "\">$title ";
+ $r->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...");
+ unless ($dbh = DBI->connect("dbi:Pg:dbname=pr0n;host=127.0.0.1", "pr0n", "EsVdwImY")) {
+ $dbh = undef;
+ die "Couldn't connect to PostgreSQL database";
+ }
+ }
+
+ 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";
+}
+
+sub get_cache_location {
+ my ($r, $id, $width, $height, $infobox) = @_;
+ my $dir = POSIX::floor($id / 256);
+
+ if ($infobox) {
+ return get_base($r) . "cache/$dir/$id-$width-$height.jpg";
+ } else {
+ return get_base($r) . "cache/$dir/$id-$width-$height-nobox.jpg";
+ }
+}
+
+sub update_width_height {
+ my ($r, $id, $width, $height) = @_;
+
+ # Also find the date taken if appropriate (from the EXIF tag etc.)
+ my $info = Image::ExifTool::ImageInfo(get_disk_location($r, $id));
+ my $datetime = undef;
+
+ if (defined($info->{'DateTimeOriginal'})) {
+ # Parse the date and time over to ISO format
+ if ($info->{'DateTimeOriginal'} =~ /^(\d{4}):(\d\d):(\d\d) (\d\d):(\d\d):(\d\d)$/ && $1 > 1990) {
+ $datetime = "$1-$2-$3 $4:$5:$6";
+ }
+ }
+
+ $dbh->do('UPDATE images SET width=?, height=?, date=? WHERE id=?',
+ undef, $width, $height, $datetime, $id)
+ or die "Couldn't update width/height in SQL: $!";
+
+ # update the last_picture cache as well (this should of course be done
+ # via a trigger, but this is less complicated :-) )
+ $dbh->do('UPDATE events SET last_picture=(SELECT COALESCE(MAX(date),\'1970-01-01 00:00:00\') FROM images WHERE event=events.id) WHERE id=(SELECT event FROM images WHERE id=?)',
+ undef, $id)
+ or die "Couldn't update last_picture in SQL: $!";
+}
+
+sub check_access {
+ my $r = shift;
+
+ my $auth = $r->headers_in->{'authorization'};
+ if (!defined($auth) || $auth !~ m#^Basic ([a-zA-Z0-9+/]+=*)$#) {
+ $r->content_type('text/plain; charset=utf-8');
+ $r->status(401);
+ $r->headers_out->{'www-authenticate'} = 'Basic realm="pr0n.sesse.net"';
+ $r->print("Need authorization\n");
+ return undef;
+ }
+
+ #return qw(sesse Sesse);
+
+ my ($user, $pass) = split /:/, MIME::Base64::decode_base64($1);
+ # WinXP is stupid :-)
+ if ($user =~ /^.*\\(.*)$/) {
+ $user = $1;
+ }
+
+ my $takenby;
+ if ($user =~ /^([a-zA-Z0-9^_-]+)\@([a-zA-Z0-9^_-]+)$/) {
+ $user = $1;
+ $takenby = $2;
+ } else {
+ ($takenby = $user) =~ s/^([a-zA-Z])/uc($1)/e;
+ }
+
+ my $oldpass = $pass;
+ $pass = Digest::SHA1::sha1_base64($pass);
+ my $ref = $dbh->selectrow_hashref('SELECT count(*) AS auth FROM users WHERE username=? AND sha1password=? AND vhost=?',
+ undef, $user, $pass, $r->get_server_name);
+ if ($ref->{'auth'} != 1) {
+ $r->content_type('text/plain; charset=utf-8');
+ warn "No user exists, only $auth";
+ $r->status(401);
+ $r->headers_out->{'www-authenticate'} = 'Basic realm="pr0n.sesse.net"';
+ $r->print("Authorization failed");
+ $r->log->warn("Authentication failed for $user/$takenby");
+ return undef;
+ }
+
+ $r->log->info("Authentication succeeded for $user/$takenby");
+
+ return ($user, $takenby);
+}
+
+sub stat_image {
+ my ($r, $event, $filename) = (@_);
+ my $ref = $dbh->selectrow_hashref(
+ 'SELECT id FROM images WHERE event=? AND filename=?',
+ undef, $event, $filename);
+ if (!defined($ref)) {
+ return (undef, undef, undef);
+ }
+ return stat_image_from_id($r, $ref->{'id'});
+}
+
+sub stat_image_from_id {
+ my ($r, $id) = @_;
+
+ my $fname = get_disk_location($r, $id);
+ my (undef, undef, undef, undef, undef, undef, undef, $size, undef, $mtime) = stat($fname)
+ or return (undef, undef, undef);
+
+ return ($fname, $size, $mtime);
+}
+
+sub ensure_cached {
+ my ($r, $filename, $id, $dbwidth, $dbheight, $infobox, $xres, $yres, @otherres) = @_;
+
+ my $fname = get_disk_location($r, $id);
+ unless (defined($xres) && ($xres < $dbheight || $yres < $dbwidth || $dbwidth == -1 || $dbheight == -1)) {
+ return ($fname, 0);
+ }
+
+ my $cachename = get_cache_location($r, $id, $xres, $yres, $infobox);
+ if (! -r $cachename or (-M $cachename > -M $fname)) {
+ # 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");
+ error($r, 'System is in overload mode, not doing any scaling');
+ }
+
+ # Need to generate the cache; read in the image
+ my $magick = new Image::Magick;
+ my $info = Image::ExifTool::ImageInfo($fname);
+
+ # NEF files aren't autodetected
+ $fname = "NEF:$fname" if ($filename =~ /\.nef$/i);
+ $r->log->warn("Generating $fname for $filename");
+
+ my $err = $magick->Read($fname);
+ if ($err) {
+ $r->log->warn("$fname: $err");
+ $err =~ /(\d+)/;
+ if ($1 >= 400) {
+ undef $magick;
+ error($r, "$fname: $err");
+ }
+ }
+
+ # If we use ->[0] unconditionally, text rendering (!) seems to crash
+ my $img = (scalar @$magick > 1) ? $magick->[0] : $magick;
+
+ my $width = $img->Get('columns');
+ my $height = $img->Get('rows');
+
+ # Update the SQL database if it doesn't contain the required info
+ if ($dbwidth == -1 || $dbheight == -1) {
+ $r->log->info("Updating width/height for $id: $width x $height");
+ update_width_height($r, $id, $width, $height);
+ }
+
+ # We always want RGB JPEGs
+ if ($img->Get('Colorspace') eq "CMYK") {
+ $img->Set(colorspace=>'RGB');
+ }
+
+ while (defined($xres) && defined($yres)) {
+ my ($nxres, $nyres) = (shift @otherres, shift @otherres);
+ my $cachename = get_cache_location($r, $id, $xres, $yres, $infobox);
+
+ my $cimg;
+ if (defined($nxres) && defined($nyres)) {
+ # we have more resolutions to scale, so don't throw
+ # the image away
+ $cimg = $img->Clone();
+ } else {
+ $cimg = $img;
+ }
+
+ my ($nwidth, $nheight) = scale_aspect($width, $height, $xres, $yres);
+
+ # Use lanczos (sharper) for heavy scaling, mitchell (faster) otherwise
+ my $filter = 'Mitchell';
+ my $quality = 90;
+
+ if ($width / $nwidth > 8.0 || $height / $nheight > 8.0) {
+ $filter = 'Lanczos';
+ $quality = 80;
+ }
+
+ $cimg->Resize(width=>$nwidth, height=>$nheight, filter=>$filter);
+
+ if (($nwidth >= 800 || $nheight >= 600) && $infobox == 1) {
+ make_infobox($cimg, $info, $r);
+ }
+
+ # Strip EXIF tags etc.
+ $cimg->Strip();
+
+ $err = $cimg->write(filename=>$cachename, quality=>$quality);
+
+ undef $cimg;
+
+ ($xres, $yres) = ($nxres, $nyres);
+
+ $r->log->info("New cache: $nwidth x $nheight for $id.jpg");
+ }
+
+ undef $magick;
+ undef $img;
+ if ($err) {
+ $r->log->warn("$fname: $err");
+ $err =~ /(\d+)/;
+ if ($1 >= 400) {
+ @$magick = ();
+ error($r, "$fname: $err");
+ }
+ }
+ }
+ return ($cachename, 1);
+}
+
+sub get_mimetype_from_filename {
+ my $filename = shift;
+ my MIME::Type $type = $mimetypes->mimeTypeOf($filename);
+ $type = "image/jpeg" if (!defined($type));
+ return $type;
+}
+
+sub make_infobox {
+ my ($img, $info, $r) = @_;
+
+ my @lines = ();
+ my @classic_fields = ();
+
+ if (defined($info->{'DateTimeOriginal'}) &&
+ $info->{'DateTimeOriginal'} =~ /^(\d{4}):(\d\d):(\d\d) (\d\d):(\d\d):(\d\d)$/
+ && $1 >= 1990) {
+ push @lines, "$1-$2-$3 $4:$5";
+ }
+
+ push @lines, $info->{'Model'} if (defined($info->{'Model'}));
+
+ # classic fields
+ if (defined($info->{'FocalLength'}) && $info->{'FocalLength'} =~ /^(\d+)(?:\.\d+)?(?:mm)?$/) {
+ push @classic_fields, ($1 . "mm");
+ } elsif (defined($info->{'FocalLength'}) && $info->{'FocalLength'} =~ /^(\d+)\/(\d+)$/) {
+ push @classic_fields, (sprintf "%.1fmm", ($1/$2));
+ }
+ if (defined($info->{'ExposureTime'}) && $info->{'ExposureTime'} =~ /^(\d+)\/(\d+)$/) {
+ my ($a, $b) = ($1, $2);
+ my $gcd = gcd($a, $b);
+ push @classic_fields, ($a/$gcd . "/" . $b/$gcd . "s");
+ }
+ if (defined($info->{'FNumber'}) && $info->{'FNumber'} =~ /^(\d+)\/(\d+)$/) {
+ my $f = $1/$2;
+ if ($f >= 10) {
+ push @classic_fields, (sprintf "f/%.0f", $f);
+ } else {
+ push @classic_fields, (sprintf "f/%.1f", $f);
+ }
+ } elsif (defined($info->{'FNumber'}) && $info->{'FNumber'} =~ /^(\d+)\.(\d+)$/) {
+ my $f = $info->{'FNumber'};
+ if ($f >= 10) {
+ push @classic_fields, (sprintf "f/%.0f", $f);
+ } else {
+ push @classic_fields, (sprintf "f/%.1f", $f);
+ }
+ }
+
+# Apache2::ServerUtil->server->log_error(join(':', keys %$info));
+
+ if (defined($info->{'NikonD1-ISOSetting'})) {
+ push @classic_fields, $info->{'NikonD1-ISOSetting'}->[1] . " ISO";
+ } elsif (defined($info->{'ISOSetting'})) {
+ push @classic_fields, $info->{'ISOSetting'} . " ISO";
+ }
+
+ push @classic_fields, $info->{'ExposureBiasValue'} . " EV" if (defined($info->{'ExposureBiasValue'}) && $info->{'ExposureBiasValue'} != 0);
+
+ if (scalar @classic_fields > 0) {
+ push @lines, join(', ', @classic_fields);
+ }
+
+ if (defined($info->{'Flash'})) {
+ if ($info->{'Flash'} =~ /did not fire/ || $info->{'Flash'} =~ /No Flash/) {
+ push @lines, "No flash";
+ } elsif ($info->{'Flash'} =~ /fired/) {
+ push @lines, "Flash";
+ } else {
+ push @lines, $info->{'Flash'};
+ }
+ }
+
+ return if (scalar @lines == 0);
+
+ # OK, this sucks. Let's make something better :-)
+ @lines = ( join(" - ", @lines) );
+
+ # Find the required width
+ my $th = 14 * (scalar @lines) + 6;
+ my $tw = 1;
+
+ for my $line (@lines) {
+ my $this_w = ($img->QueryFontMetrics(text=>$line, font=>'/usr/share/fonts/truetype/msttcorefonts/Arial.ttf', pointsize=>12))[4];
+ $tw = $this_w if ($this_w >= $tw);
+ }
+
+ $tw += 6;
+
+ # Round up so we hit exact DCT blocks
+ $tw += 8 - ($tw % 8) unless ($tw % 8 == 0);
+ $th += 8 - ($th % 8) unless ($th % 8 == 0);
+
+ return if ($tw > $img->Get('columns'));
+
+# my $x = $img->Get('columns') - 8 - $tw;
+# my $y = $img->Get('rows') - 8 - $th;
+ my $x = 0;
+ my $y = $img->Get('rows') - $th;
+ $tw = $img->Get('columns');
+
+ $x -= $x % 8;
+ $y -= $y % 8;
+
+ my $points = sprintf "%u,%u %u,%u", $x, $y, ($x+$tw-1), ($img->Get('rows') - 1);
+ my $lpoints = sprintf "%u,%u %u,%u", $x, $y, ($x+$tw-1), $y;
+# $img->Draw(primitive=>'rectangle', stroke=>'black', fill=>'white', points=>$points);
+ $img->Draw(primitive=>'rectangle', stroke=>'white', fill=>'white', points=>$points);
+ $img->Draw(primitive=>'line', stroke=>'black', points=>$lpoints);
+
+ my $i = -(scalar @lines - 1)/2.0;
+ my $xc = $x + $tw / 2 - $img->Get('columns')/2;
+ my $yc = ($y + $img->Get('rows'))/2 - $img->Get('rows')/2;
+ #my $yc = ($y + $img->Get('rows'))/4;
+ my $yi = $th / (scalar @lines);
+
+ $lpoints = sprintf "%u,%u %u,%u", $x, $yc + $img->Get('rows')/2, ($x+$tw-1), $yc+$img->Get('rows')/2;
+
+ for my $line (@lines) {
+ $img->Annotate(text=>$line, font=>'/usr/share/fonts/truetype/msttcorefonts/Arial.ttf', pointsize=>12, gravity=>'Center',
+ # $img->Annotate(text=>$line, font=>'Helvetica', pointsize=>12, gravity=>'Center',
+ x=>int($xc), y=>int($yc + $i * $yi));
+
+ $i = $i + 1;
+ }
+}
+
+sub gcd {
+ my ($a, $b) = @_;
+ return $a if ($b == 0);
+ return gcd($b, $a % $b);
+}
+
+1;
+
+
diff --git a/perl/Sesse/pr0n/Image.pm b/perl/Sesse/pr0n/Image.pm
new file mode 100644
index 0000000..30bf736
--- /dev/null
+++ b/perl/Sesse/pr0n/Image.pm
@@ -0,0 +1,85 @@
+package Sesse::pr0n::Image;
+use strict;
+use warnings;
+
+use Sesse::pr0n::Common qw(error dberror);
+use POSIX;
+
+sub handler {
+ my $r = shift;
+ my $dbh = Sesse::pr0n::Common::get_dbh();
+
+# if ($r->connection->remote_ip() eq '80.212.251.227') {
+# die "Har du lest FAQen?";
+# }
+
+ # Find the event and file name
+ my ($event,$filename,$xres,$yres);
+ my $infobox = 1;
+ if ($r->uri =~ m#^/([a-zA-Z0-9-]+)/([a-zA-Z0-9._-]+)$#) {
+ $event = $1;
+ $filename = $2;
+ } elsif ($r->uri =~ m#^/([a-zA-Z0-9-]+)/(\d+)x(\d+)/(nobox/)?([a-zA-Z0-9._-]+)$#) {
+ $event = $1;
+ $filename = $5;
+ $xres = $2;
+ $yres = $3;
+ $infobox = 0 if (defined($4));
+ }
+
+ my ($id, $dbwidth, $dbheight);
+ if ($event eq 'single' && $filename =~ /^(\d+)\.jpeg$/) {
+ $id = $1;
+ } else {
+ # Alas, we obviously need to do this :-)
+ # my $evq = $dbh->prepare('SELECT count(*) AS numev FROM events WHERE id=? AND vhost=?')
+ # or die "prepare(): $!";
+ # my $ref = $dbh->selectrow_hashref($evq, undef, $event, $r->get_server_name)
+ # or dberror($r, "Could not look up $event");
+ # $ref->{'numev'} == 1
+ # or error($r, "Could not find $event", 404, "File not found");
+
+ # Look it up in the database
+ my $ref = $dbh->selectrow_hashref('SELECT id,width,height FROM images WHERE event=? AND filename=?',
+ undef, $event, $filename);
+ error($r, "Could not find $event/$filename", 404, "File not found") unless (defined($ref));
+
+ $id = $ref->{'id'};
+ $dbwidth = $ref->{'width'};
+ $dbheight = $ref->{'height'};
+ }
+
+ $dbwidth = -1 unless defined($dbwidth);
+ $dbheight = -1 unless defined($dbheight);
+
+ # Scale if we need to do so
+ my ($fname,$thumbnail) = Sesse::pr0n::Common::ensure_cached($r, $filename, $id, $dbwidth, $dbheight, $infobox, $xres, $yres);
+
+ # Output the image to the user
+ my $mime_type;
+ if ($thumbnail) {
+ $mime_type = "image/jpeg";
+ } else {
+ $mime_type = Sesse::pr0n::Common::get_mimetype_from_filename($filename);
+ }
+ $r->content_type($mime_type);
+
+ my (undef, undef, undef, undef, undef, undef, undef, $size, undef, $mtime) = stat($fname)
+ or 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;
+ }
+
+ $r->sendfile($fname);
+
+ return Apache2::Const::OK;
+}
+
+1;
+
+
diff --git a/perl/Sesse/pr0n/Index.pm b/perl/Sesse/pr0n/Index.pm
new file mode 100644
index 0000000..1782453
--- /dev/null
+++ b/perl/Sesse/pr0n/Index.pm
@@ -0,0 +1,454 @@
+package Sesse::pr0n::Index;
+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();
+
+ # Find the event
+ $r->uri =~ m#^/([a-zA-Z0-9-]+)/?$#
+ or error($r, "Could not extract event");
+ my $event = $1;
+
+ # Fix common error: pr0n.sesse.net/event -> pr0n.sesse.net/event/
+ if ($r->uri !~ m#/$#) {
+ $r->headers_out->{'location'} = "/$event/";
+ return Apache2::Const::REDIRECT;
+ }
+
+ # Internal? (Ugly?)
+ if ($r->get_server_name =~ /internal/) {
+ my $user = Sesse::pr0n::Common::check_access($r);
+ if (!defined($user)) {
+ return Apache2::Const::OK;
+ }
+ }
+
+ # Read the appropriate settings from the query string into the settings hash
+ my %defsettings = (
+ thumbxres => 80,
+ thumbyres => 64,
+ xres => undef,
+ yres => undef,
+ start => 1,
+ num => -1,
+ all => 1,
+ infobox => 1,
+ rot => 0,
+ sel => 0,
+ );
+
+ # Reduce the front page load when in overload mode.
+ if (Sesse::pr0n::Overload::is_in_overload($r)) {
+ $defsettings{'num'} = 100;
+ }
+
+ my %settings = %defsettings;
+
+ for my $s qw(thumbxres thumbyres xres yres start num all infobox rot sel) {
+ my $val = $apr->param($s);
+ if (defined($val) && $val =~ /^(\d+)$/) {
+ $settings{$s} = $val;
+ }
+ if ($s eq "num" && defined($val) && $val == -1) {
+ $settings{$s} = $val;
+ }
+ }
+
+ my $thumbxres = $settings{'thumbxres'};
+ my $thumbyres = $settings{'thumbyres'};
+ my $xres = $settings{'xres'};
+ my $yres = $settings{'yres'};
+ my $start = $settings{'start'};
+ my $num = $settings{'num'};
+ my $all = $settings{'all'};
+ my $infobox = $settings{'infobox'} ? '' : 'nobox/';
+ my $rot = $settings{'rot'};
+ my $sel = $settings{'sel'};
+
+ if (defined($num) && $num == -1) {
+ $num = undef;
+ }
+
+ my $ref = $dbh->selectrow_hashref('SELECT * FROM events WHERE id=? AND vhost=?',
+ undef, $event, $r->get_server_name)
+ or error($r, "Could not find event $event", 404, "File not found");
+
+ my $name = $ref->{'name'};
+ my $date = $ref->{'date'};
+
+ # Count the number of selected images.
+ $ref = $dbh->selectrow_hashref("SELECT COUNT(*) AS num_selected FROM images WHERE event=? AND selected=\'t\'", undef, $event);
+ my $num_selected = $ref->{'num_selected'};
+
+ # Find all images related to this event.
+ my $q;
+ my $where = ($all == 0) ? ' AND selected=\'t\'' : '';
+
+ if (defined($start) && defined($num)) {
+ $q = $dbh->prepare("SELECT *, (date - INTERVAL '6 hours')::date AS day FROM images WHERE event=? $where ORDER BY (date - INTERVAL '6 hours')::date,takenby,date,filename LIMIT $num OFFSET " . ($start-1))
+ or dberror($r, "prepare()");
+ } else {
+ $q = $dbh->prepare("SELECT *, (date - INTERVAL '6 hours')::date AS day FROM images WHERE event=? $where ORDER BY (date - INTERVAL '6 hours')::date,takenby,date,filename")
+ or dberror($r, "prepare()");
+ }
+ $q->execute($event)
+ or dberror($r, "image enumeration");
+
+ # Print the page itself
+ Sesse::pr0n::Common::header($r, "$name [$event]");
+ Sesse::pr0n::Templates::print_template($r, "date", { date => $date });
+
+ if (Sesse::pr0n::Overload::is_in_overload($r)) {
+ Sesse::pr0n::Templates::print_template($r, "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_nextprev($r, $event, \%settings, \%defsettings);
+ print_selected($r, $event, \%settings, \%defsettings) if ($num_selected > 0);
+
+ my $toclose = 0;
+ my $lastupl = "";
+
+ # Print out all thumbnails
+ if ($rot == 1) {
+ $r->print(" \n");
+ } elsif ($sel == 1) {
+ $r->print(" \n");
+ } else {
+ while (my $ref = $q->fetchrow_hashref()) {
+ my $imgsz = "";
+ my $takenby = $ref->{'takenby'};
+ if (defined($ref->{'day'})) {
+ $takenby .= ", " . $ref->{'day'};
+ }
+
+ if ($takenby ne $lastupl) {
+ $r->print("
\n\n") if ($lastupl ne "");
+ $lastupl = $takenby;
+ Sesse::pr0n::Templates::print_template($r, "submittedby", { author => $lastupl });
+ $r->print(" \n");
+ }
+ if ($ref->{'width'} != -1 && $ref->{'height'} != -1) {
+ my $width = $ref->{'width'};
+ my $height = $ref->{'height'};
+
+ ($width, $height) = Sesse::pr0n::Common::scale_aspect($width, $height, $thumbxres, $thumbyres);
+ $imgsz = " width=\"$width\" height=\"$height\"";
+ }
+
+ my $filename = $ref->{'filename'};
+ my $uri = $filename;
+ if (defined($xres) && defined($yres)) {
+ $uri = "${xres}x$yres/$infobox$filename";
+ }
+
+ $r->print(" \n");
+ }
+ $r->print("
\n");
+ }
+
+ print_nextprev($r, $event, \%settings, \%defsettings);
+ Sesse::pr0n::Common::footer($r);
+
+ return Apache2::Const::OK;
+}
+
+sub eq_with_undef {
+ my ($a, $b) = @_;
+
+ return 1 if (!defined($a) && !defined($b));
+ return 0 unless (defined($a) && defined($b));
+ return ($a eq $b);
+}
+
+sub print_changes {
+ my ($r, $event, $template, $settings, $defsettings, $var1, $var2, $alternatives) = @_;
+
+ my $title = Sesse::pr0n::Templates::fetch_template($r, $template);
+ chomp $title;
+ $r->print(" $title:\n");
+
+ for my $a (@$alternatives) {
+ # Parse the current alternative
+ my ($v1, $v2) = split /x/, $a;
+ my %newsettings = %$settings;
+
+ if (defined($v1) && defined($v2)) {
+ $newsettings{$var1} = $v1;
+ $newsettings{$var2} = $v2;
+ } else {
+ $newsettings{$var1} = undef;
+ $newsettings{$var2} = undef;
+ }
+
+ $r->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($a);
+ } else {
+ Sesse::pr0n::Common::print_link($r, $a, "/$event/", \%newsettings, $defsettings);
+ }
+ $r->print("\n");
+ }
+ $r->print("
\n");
+}
+
+sub print_thumbsize {
+ my ($r, $event, $settings, $defsettings) = @_;
+ my @alternatives = qw(80x64 120x96 160x128 240x192 320x256);
+
+ print_changes($r, $event, 'thumbsize', $settings, $defsettings,
+ 'thumbxres', 'thumbyres', \@alternatives);
+}
+sub print_viewres {
+ my ($r, $event, $settings, $defsettings) = @_;
+ my @alternatives = qw(320x256 512x384 640x480 800x600 1024x768 1280x960);
+ chomp (my $unlimited = Sesse::pr0n::Templates::fetch_template($r, 'viewres-unlimited'));
+ push @alternatives, $unlimited;
+
+ print_changes($r, $event, 'viewres', $settings, $defsettings,
+ 'xres', 'yres', \@alternatives);
+}
+
+sub print_pagelimit {
+ my ($r, $event, $settings, $defsettings) = @_;
+
+ my $title = Sesse::pr0n::Templates::fetch_template($r, 'imgsperpage');
+ chomp $title;
+ $r->print(" $title:\n");
+
+ # Get choices
+ chomp (my $unlimited = Sesse::pr0n::Templates::fetch_template($r, 'imgsperpage-unlimited'));
+ my @alternatives = qw(10 50 100 500);
+ push @alternatives, $unlimited;
+
+ for my $num (@alternatives) {
+ my %newsettings = %$settings;
+
+ if ($num !~ /^\d+$/) { # unlimited
+ $newsettings{'num'} = -1;
+ } else {
+ $newsettings{'num'} = $num;
+ }
+
+ $r->print(" ");
+ if (eq_with_undef($settings->{'num'}, $newsettings{'num'})) {
+ $r->print($num);
+ } else {
+ Sesse::pr0n::Common::print_link($r, $num, "/$event/", \%newsettings, $defsettings);
+ }
+ $r->print("\n");
+ }
+ $r->print("
\n");
+}
+
+sub print_infobox {
+ my ($r, $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");
+
+ my %newsettings = %$settings;
+
+ if ($settings->{'infobox'} == 1) {
+ $r->print($on);
+ } else {
+ $newsettings{'infobox'} = 1;
+ Sesse::pr0n::Common::print_link($r, $on, "/$event/", \%newsettings, $defsettings);
+ }
+
+ $r->print(' ');
+
+ if ($settings->{'infobox'} == 0) {
+ $r->print($off);
+ } else {
+ $newsettings{'infobox'} = 0;
+ Sesse::pr0n::Common::print_link($r, $off, "/$event/", \%newsettings, $defsettings);
+ }
+
+ $r->print('
');
+}
+
+sub print_nextprev {
+ my ($r, $event, $settings, $defsettings) = @_;
+ my $start = $settings->{'start'};
+ my $num = $settings->{'num'};
+ my $dbh = Sesse::pr0n::Common::get_dbh();
+
+ $num = undef if (defined($num) && $num == -1);
+ return unless (defined($start) && defined($num));
+
+ # determine total number
+ my $ref = $dbh->selectrow_hashref('SELECT count(*) AS num_images FROM images WHERE event=?',
+ undef, $event)
+ or dberror($r, "image enumeration");
+ my $num_images = $ref->{'num_images'};
+
+ return if ($start == 1 && $start + $num >= $num_images);
+
+ my $end = $start + $num - 1;
+ if ($end > $num_images) {
+ $end = $num_images;
+ }
+
+ $r->print(" \n");
+
+ # Previous
+ if ($start > 1) {
+ my $newstart = $start - $num;
+ if ($newstart < 1) {
+ $newstart = 1;
+ }
+ my $newend = $newstart + $num - 1;
+ if ($newend > $num_images) {
+ $newend = $num_images;
+ }
+
+ my %newsettings = %$settings;
+ $newsettings{'start'} = $newstart;
+ chomp (my $title = Sesse::pr0n::Templates::fetch_template($r, 'prevpage'));
+ Sesse::pr0n::Common::print_link($r, "$title ($newstart-$newend)\n", "/$event/", \%newsettings, $defsettings);
+ }
+
+ # This
+ chomp (my $title = Sesse::pr0n::Templates::fetch_template($r, 'thispage'));
+ $r->print(" $title ($start-$end)\n");
+
+ # Next
+ if ($end < $num_images) {
+ my $newstart = $start + $num;
+ my $newend = $newstart + $num - 1;
+ if ($newend > $num_images) {
+ $newend = $num_images;
+ }
+
+ my %newsettings = %$settings;
+ $newsettings{'start'} = $newstart;
+ chomp (my $title = Sesse::pr0n::Templates::fetch_template($r, 'nextpage'));
+ Sesse::pr0n::Common::print_link($r, "$title ($newstart-$newend)", "/$event/", \%newsettings, $defsettings);
+ }
+
+ $r->print("
\n");
+}
+
+sub print_selected {
+ my ($r, $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");
+
+ my %newsettings = %$settings;
+
+ if ($settings->{'all'} == 0) {
+ $r->print($sel);
+ } else {
+ $newsettings{'all'} = 0;
+ Sesse::pr0n::Common::print_link($r, $sel, "/$event/", \%newsettings, $defsettings);
+ }
+
+ $r->print(' ');
+
+ if ($settings->{'all'} == 1) {
+ $r->print($all);
+ } else {
+ $newsettings{'all'} = 1;
+ Sesse::pr0n::Common::print_link($r, $all, "/$event/", \%newsettings, $defsettings);
+ }
+
+ $r->print('
');
+}
+
+1;
+
+
diff --git a/perl/Sesse/pr0n/Listing.pm b/perl/Sesse/pr0n/Listing.pm
new file mode 100644
index 0000000..8447040
--- /dev/null
+++ b/perl/Sesse/pr0n/Listing.pm
@@ -0,0 +1,49 @@
+package Sesse::pr0n::Listing;
+use strict;
+use warnings;
+
+use Sesse::pr0n::Common qw(error dberror);
+
+sub handler {
+ my $r = shift;
+ my $dbh = Sesse::pr0n::Common::get_dbh();
+
+ # Internal? (Ugly?)
+ if ($r->get_server_name =~ /internal/) {
+ my $user = Sesse::pr0n::Common::check_access($r);
+ if (!defined($user)) {
+ return Apache2::Const::OK;
+ }
+ }
+
+# 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 id,date,name FROM events WHERE vhost=? ORDER BY last_picture DESC')
+ or dberror($r, "Couldn't list events");
+ $q->execute($r->get_server_name)
+ or dberror($r, "Couldn't get events");
+
+ $r->content_type('text/html; charset=utf-8');
+ $r->subprocess_env;
+
+ Sesse::pr0n::Common::header($r, Sesse::pr0n::Templates::fetch_template($r, 'event-listing'));
+ $r->print(" \n");
+
+ while (my $ref = $q->fetchrow_hashref()) {
+ my $id = $ref->{'id'};
+ my $date = $ref->{'date'};
+ my $name = $ref->{'name'};
+
+ $r->print(" $name ($date) \n");
+ }
+
+ $r->print(" \n");
+ Sesse::pr0n::Common::footer($r);
+
+ $q->finish();
+ return Apache2::Const::OK;
+}
+
+1;
+
+
diff --git a/perl/Sesse/pr0n/NewEvent.pm b/perl/Sesse/pr0n/NewEvent.pm
new file mode 100644
index 0000000..3eaa5dd
--- /dev/null
+++ b/perl/Sesse/pr0n/NewEvent.pm
@@ -0,0 +1,55 @@
+package Sesse::pr0n::NewEvent;
+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;
+ }
+
+ Sesse::pr0n::Common::header($r, "Legger til ny hendelse");
+
+ my $ok = 1;
+
+ my $id = $apr->param('id');
+ if (!defined($id) || $id =~ /^\s*$/ || $id !~ /^([a-zA-Z0-9-]+)$/) {
+ $r->print(" Feil: Manglende eller ugyldig ID.
\n");
+ $ok = 0;
+ }
+
+ my $date = $apr->param('date');
+ if (!defined($date) || $date =~ /^\s*$/ || $date =~ /[<>&]/ || length($date) > 100) {
+ $r->print(" Feil: Manglende eller ugyldig dato.
\n");
+ $ok = 0;
+ }
+
+ my $desc = $apr->param('desc');
+ if (!defined($desc) || $desc =~ /^\s*$/ || $desc =~ /[<>&]/ || length($desc) > 100) {
+ $r->print(" Feil: Manglende eller ugyldig beskrivelse.
\n");
+ $ok = 0;
+ }
+
+ if ($ok == 0) {
+ $r->print(" Rett opp i feilene over før du går videre.
\n");
+ } else {
+ $dbh->do("INSERT INTO events (id,date,name,vhost) VALUES (?,?,?,?)",
+ undef, $id, $date, $desc, $r->get_server_name)
+ or dberror($r, "Kunne ikke sette inn ny hendelse");
+ $r->print(" Hendelsen '$id' lagt til.
");
+ }
+
+ Sesse::pr0n::Common::footer($r);
+
+ return Apache2::Const::OK;
+}
+
+1;
+
+
diff --git a/perl/Sesse/pr0n/Overload.pm b/perl/Sesse/pr0n/Overload.pm
new file mode 100644
index 0000000..0adce7c
--- /dev/null
+++ b/perl/Sesse/pr0n/Overload.pm
@@ -0,0 +1,70 @@
+# Note: This package is shared between server processes as much as we can,
+# for obvious reasons (you don't want just half the server to go in
+# overload mode if you can help it)
+
+package Sesse::pr0n::Overload;
+use strict;
+use warnings;
+
+BEGIN {
+ use Exporter ();
+ our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
+
+ $VERSION = 1.00;
+ @ISA = qw(Exporter);
+ @EXPORT = qw();
+ %EXPORT_TAGS = qw();
+ @EXPORT_OK = qw();
+}
+our ($last_update, $loadavg, $in_overload);
+
+sub is_in_overload {
+ my $r = shift;
+
+ # Manually set overload mode
+ if (lc($r->dir_config('OverloadMode')) eq 'on') {
+ return 1;
+ }
+
+ # By default we are not in overload mode
+ if (!defined($in_overload)) {
+ $in_overload = 0;
+ }
+
+ my $enable_threshold = $r->dir_config('OverloadEnableThreshold') || 10.0;
+ my $disable_threshold = $r->dir_config('OverloadDisableThreshold') || 5.0;
+
+ # Check if our load average estimate is more than a minute old
+ if (!defined($last_update) || (time - $last_update) > 60) {
+ open LOADAVG, ";
+ close LOADAVG;
+
+ $line =~ /^(\d+\.\d+) / or die "Couldn't parse /proc/loadavg";
+
+ $loadavg = $1;
+ $last_update = time;
+
+ if ($in_overload) {
+ if ($loadavg < $disable_threshold) {
+ $r->log->info("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");
+ }
+ } else {
+ if ($loadavg > $enable_threshold) {
+ $r->log->warn("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)");
+ }
+ }
+ }
+
+ return $in_overload;
+}
+
+1;
+
diff --git a/perl/Sesse/pr0n/Rotate.pm b/perl/Sesse/pr0n/Rotate.pm
new file mode 100644
index 0000000..923e5df
--- /dev/null
+++ b/perl/Sesse/pr0n/Rotate.pm
@@ -0,0 +1,69 @@
+package Sesse::pr0n::Rotate;
+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;
+ }
+
+ Sesse::pr0n::Common::header($r, "Rotation/deletion results");
+
+ {
+ # Enable transactions and error raising temporarily
+ local $dbh->{AutoCommit} = 0;
+ local $dbh->{RaiseError} = 1;
+
+ my @params = $apr->param();
+ my $key;
+ for $key (@params) {
+ # Rotation
+ if ($key =~ /^rot-(\d+)-(90|180|270)$/ && $apr->param($key) eq 'on') {
+ my ($id, $rotval) = ($1,$2);
+ my $fname = Sesse::pr0n::Common::get_disk_location($r, $id);
+ (my $tmpfname = $fname) =~ s/\.jpg$/-tmp.jpg/;
+
+ system("/usr/bin/jpegtran -rotate $rotval -copy all < '$fname' > '$tmpfname' && mv '$tmpfname' '$fname'") == 0
+ or error($r, "Rotation of $id [/usr/bin/jpegtran -rotate $rotval -copy all < '$fname' > '$tmpfname' && mv '$tmpfname' '$fname'] failed: $!.");
+ $r->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: $!");
+ }
+ } elsif ($key =~ /^del-(\d+)$/ && $apr->param($key) eq 'on') {
+ my $id = $1;
+ {
+
+ eval {
+ $dbh->do('INSERT INTO deleted_images SELECT * FROM images WHERE id=?',
+ undef, $id);
+ $dbh->do('DELETE FROM images WHERE id=?',
+ undef, $id);
+ };
+ if ($@) {
+# Some error occurred, rollback and bomb out
+ $dbh->rollback;
+ dberror($r, "Transaction aborted because $@");
+ }
+ }
+ $r->print(" Deleted image `$id'.
\n");
+ }
+ }
+ }
+
+ Sesse::pr0n::Common::footer($r);
+
+ return Apache2::Const::OK;
+}
+
+1;
+
+
diff --git a/perl/Sesse/pr0n/Select.pm b/perl/Sesse/pr0n/Select.pm
new file mode 100644
index 0000000..1086587
--- /dev/null
+++ b/perl/Sesse/pr0n/Select.pm
@@ -0,0 +1,47 @@
+package Sesse::pr0n::Select;
+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;
+ }
+
+ my $event = $apr->param('event');
+
+ Sesse::pr0n::Common::header($r, "Selection results");
+
+ {
+ # Enable transactions and error raising temporarily
+ local $dbh->{AutoCommit} = 0;
+ local $dbh->{RaiseError} = 1;
+
+ $dbh->do('UPDATE images SET selected=\'f\' WHERE event=?', undef, $event);
+
+ my @params = $apr->param();
+ my $key;
+ for $key (@params) {
+ if ($key =~ /^sel-(\d+)/ && $apr->param($key) eq 'on') {
+ my $id = $1;
+ my $q = $dbh->do('UPDATE images SET selected=\'t\' WHERE id=?', undef, $id)
+ or dberror($r, "Selection of $id failed: $!");
+ $r->print(" Selected image ID `$id'.
\n");
+ }
+ }
+ }
+
+ Sesse::pr0n::Common::footer($r);
+
+ return Apache2::Const::OK;
+}
+
+1;
+
+
diff --git a/perl/Sesse/pr0n/Single.pm b/perl/Sesse/pr0n/Single.pm
new file mode 100644
index 0000000..4971df7
--- /dev/null
+++ b/perl/Sesse/pr0n/Single.pm
@@ -0,0 +1,64 @@
+package Sesse::pr0n::Single;
+use strict;
+use warnings;
+
+use Sesse::pr0n::Common;
+use Sesse::pr0n::Index;
+use Apache2::Request;
+use POSIX;
+
+sub handler {
+ my $r = shift;
+ my $apr = Apache2::Request->new($r);
+
+ # Read the appropriate settings from the query string into the settings hash
+ my %defsettings = (
+ thumbxres => 80,
+ thumbyres => 64,
+ xres => undef,
+ yres => undef,
+ start => 1,
+ num => undef,
+ svurr => 0
+ );
+ my %settings = %defsettings;
+
+ for my $s qw(thumbxres thumbyres xres yres svurr start num) {
+ my $val = $apr->param($s);
+ if (defined($val) && $val =~ /^(\d+)$/) {
+ $settings{$s} = $val;
+ }
+ }
+
+ my $thumbxres = $settings{'thumbxres'};
+ my $thumbyres = $settings{'thumbyres'};
+ my $xres = $settings{'xres'};
+ my $yres = $settings{'yres'};
+ my $start = $settings{'start'};
+ my $num = $settings{'num'};
+
+ # Print the page itself
+ Sesse::pr0n::Common::header($r, "Singles");
+
+ Sesse::pr0n::Index::print_thumbsize($r, 'single', \%settings, \%defsettings);
+ Sesse::pr0n::Index::print_viewres($r, 'single', \%settings, \%defsettings);
+
+ for my $id ($start..($start+$num)) {
+ my $filename = "$id.jpeg";
+ my $uri = $filename;
+ if (defined($xres) && defined($yres)) {
+ $uri = "${xres}x$yres/$filename";
+ }
+
+ $r->print(" \n");
+ }
+ $r->print(" \n");
+
+ Sesse::pr0n::Common::footer($r);
+
+ return Apache2::Const::OK;
+}
+
+1;
+
+
diff --git a/perl/Sesse/pr0n/Templates.pm b/perl/Sesse/pr0n/Templates.pm
new file mode 100644
index 0000000..4227486
--- /dev/null
+++ b/perl/Sesse/pr0n/Templates.pm
@@ -0,0 +1,87 @@
+package Sesse::pr0n::Templates;
+use strict;
+use warnings;
+
+use Sesse::pr0n::Common qw(error dberror);
+
+BEGIN {
+ use Exporter ();
+ our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
+
+ $VERSION = 1.00;
+ @ISA = qw(Exporter);
+ @EXPORT = qw();
+ %EXPORT_TAGS = qw();
+ @EXPORT_OK = qw();
+}
+our %dirs;
+
+sub update_dirs {
+ my $r = shift;
+ my $base = $r->dir_config('TemplateBase');
+ %dirs = ();
+
+ for my $dir (<$base/*>) {
+ next unless -d $dir;
+ $dir =~ m#/([^/]+)$#;
+
+ warn "Templates exist for '$1'";
+ $dirs{$1} = {};
+ }
+}
+
+sub r_to_dir {
+ my $r = shift;
+
+ if (!defined(%dirs)) {
+ update_dirs($r);
+ }
+
+ my $site = $r->get_server_name();
+ if (defined($dirs{$site})) {
+ return $site;
+ } else {
+ return "default";
+ }
+}
+
+sub fetch_template {
+ my ($r, $template) = @_;
+
+ my $dir = r_to_dir($r);
+ my $cache = $dirs{$dir}{$template};
+ if (defined($cache) && time - $cache->{'time'} <= 300) {
+ return $cache->{'contents'};
+ }
+
+ my $newcache = {};
+
+ my $base = $r->dir_config('TemplateBase');
+ open TEMPLATE, "<$base/$dir/$template"
+ or Sesse::pr0n::Common::error($r, "Couldn't open $dir/$template: $!");
+
+ local $/;
+ $newcache->{'contents'} = ;
+
+ close TEMPLATE;
+
+ $newcache->{'time'} = time;
+ $dirs{$dir}{$template} = $newcache;
+ return $newcache->{'contents'};
+}
+
+sub print_template {
+ my ($r, $template, $args) = @_;
+ my $text = fetch_template($r, $template);
+
+ # do substitutions
+ while (my ($key, $value) = each (%$args)) {
+ $key = "%" . uc($key) . "%";
+ $text =~ s/$key/$value/g;
+ }
+
+ $r->print($text);
+}
+
+1;
+
diff --git a/perl/Sesse/pr0n/WebDAV.pm b/perl/Sesse/pr0n/WebDAV.pm
new file mode 100644
index 0000000..35cc979
--- /dev/null
+++ b/perl/Sesse/pr0n/WebDAV.pm
@@ -0,0 +1,606 @@
+package Sesse::pr0n::WebDAV;
+use strict;
+use warnings;
+
+use Sesse::pr0n::Common qw(error dberror);
+use Digest::SHA1;
+use MIME::Base64;
+
+sub handler {
+ my $r = shift;
+ my $dbh = Sesse::pr0n::Common::get_dbh();
+
+ $r->headers_out->{'DAV'} = "1,2";
+
+ # We only handle depth=0, depth=1 (cf. the RFC)
+ my $depth = $r->headers_in->{'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;
+ }
+
+ # 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;
+ }
+
+ # Directory listings et al
+ if ($r->method eq "PROPFIND") {
+ $r->content_type('text/xml; charset="utf-8"');
+ $r->status(207);
+
+ if ($r->uri =~ m#^/webdav/?$#) {
+ $r->headers_out->{'content-location'} = "/webdav/";
+
+ # Root directory
+ $r->print(<<"EOF");
+
+
+
+ /webdav/
+
+
+
+ text/xml
+
+ HTTP/1.1 200 OK
+
+
+EOF
+
+ # Optionally list the upload/ dir
+ if ($depth >= 1) {
+ $r->print(<<"EOF");
+
+ /webdav/upload/
+
+
+
+ text/xml
+
+ HTTP/1.1 200 OK
+
+
+EOF
+ }
+ $r->print(" \n");
+ } elsif ($r->uri =~ m#^/webdav/upload/?$#) {
+ $r->headers_out->{'content-location'} = "/webdav/upload/";
+
+ # Upload root directory
+ $r->print(<<"EOF");
+
+
+
+ /webdav/upload/
+
+
+
+ text/xml
+
+ HTTP/1.1 200 OK
+
+
+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");
+
+ while (my $ref = $q->fetchrow_hashref()) {
+ my $id = $ref->{'id'};
+ my $name = $ref->{'name'};
+
+ $name =~ s/&/\&/g; # hack :-)
+ $r->print(<<"EOF");
+
+ /webdav/upload/$id/
+
+
+
+ text/xml
+ $name
+
+ HTTP/1.1 200 OK
+
+
+EOF
+ }
+ $q->finish;
+ }
+
+ $r->print(" \n");
+ } elsif ($r->uri =~ m#^/webdav/upload/([a-zA-Z0-9-]+)/?$#) {
+ my $event = $1;
+
+ $r->headers_out->{'content-location'} = "/webdav/upload/$event/";
+
+ # Check that we do indeed exist
+ my $ref = $dbh->selectrow_hashref('SELECT count(*) AS numev FROM events WHERE id=?',
+ undef, $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;
+ }
+
+ # OK, list the directory
+ $r->print(<<"EOF");
+
+
+
+ /webdav/upload/$event/
+
+
+
+ text/xml
+
+ HTTP/1.1 200 OK
+
+
+EOF
+
+ # List all the files within too, of course :-)
+ if ($depth >= 1) {
+ my $q = $dbh->prepare('SELECT * FROM images WHERE event=?') or
+ dberror($r, "Couldn't list images");
+ $q->execute($event) or
+ dberror($r, "Couldn't get events");
+
+ while (my $ref = $q->fetchrow_hashref()) {
+ my $id = $ref->{'id'};
+ my $filename = $ref->{'filename'};
+ my $fname = Sesse::pr0n::Common::get_disk_location($r, $id);
+ my (undef, undef, undef, undef, undef, undef, undef, $size, undef, $mtime) = stat($fname)
+ or next;
+ $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");
+
+ /webdav/upload/$event/$filename
+
+
+
+ $mime_type
+ $size
+ $mtime
+
+ HTTP/1.1 200 OK
+
+
+EOF
+ }
+ $q->finish;
+
+ # And the magical autorename folder
+ $r->print(<<"EOF");
+
+ /webdav/upload/$event/autorename/
+
+
+
+ text/xml
+
+ HTTP/1.1 200 OK
+
+
+EOF
+ $r->log->info("Full list");
+ }
+
+ $r->print(" \n");
+
+ return Apache2::Const::OK;
+ } elsif ($r->uri =~ 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/";
+
+ # Check that we do indeed exist
+ my $ref = $dbh->selectrow_hashref('SELECT count(*) AS numev FROM events WHERE id=?',
+ undef, $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;
+ }
+
+ # OK, list the (empty) directory
+ $r->print(<<"EOF");
+
+
+
+ /webdav/upload/$event/autorename/
+
+
+
+ text/xml
+
+ HTTP/1.1 200 OK
+
+
+
+EOF
+
+ return Apache2::Const::OK;
+ } elsif ($r->uri =~ 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 filename=? AND expires_at > now()',
+ undef, $event, $filename);
+ if ($ref->{'numfiles'} == 1) {
+ $fname = "/dev/null";
+ $size = 0;
+ $mtime = time;
+ } else {
+ ($fname, $size, $mtime) = Sesse::pr0n::Common::stat_image($r, $event, $filename);
+ }
+
+ if (!defined($fname)) {
+ $r->status(404);
+ $r->content_type('text/plain; charset=utf-8');
+ $r->print("Couldn't find file");
+ return Apache2::Const::OK;
+ }
+ 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");
+
+
+
+ /webdav/upload/$event/$filename
+
+
+
+ $mime_type
+ $size
+ $mtime
+
+ HTTP/1.1 200 OK
+
+
+
+EOF
+ return Apache2::Const::OK;
+ } elsif ($r->uri =~ 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 filename=? AND expires_at > now()',
+ undef, $event, $filename);
+ if ($ref->{'numfiles'} == 1) {
+ $fname = "/dev/null";
+ $size = 0;
+ $mtime = time;
+ } else {
+ # check if we have a "shadow file" for this
+ my $ref = $dbh->selectrow_hashref('SELECT id FROM shadow_files WHERE event=? AND filename=? AND expires_at > now()',
+ undef, $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;
+ }
+ 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");
+
+
+
+ /webdav/upload/$event/autorename/$filename
+
+
+
+ $mime_type
+ $size
+ $mtime
+
+ HTTP/1.1 200 OK
+
+
+
+EOF
+ } else {
+ $r->status(404);
+ $r->content_type('text/plain; charset=utf-8');
+ $r->print("Couldn't find file");
+ }
+ return Apache2::Const::OK;
+ }
+
+ 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("\nCouldn't find file
");
+ return Apache2::Const::OK;
+ }
+
+ my ($event, $autorename, $filename) = ($1, $2, $3);
+
+ # Check if this file really exists
+ 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 filename=? AND expires_at > now()',
+ undef, $event, $filename);
+ if ($ref->{'numfiles'} == 1) {
+ $fname = "/dev/null";
+ $size = 0;
+ $mtime = time;
+ } else {
+ # 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 event=? AND filename=? AND expires_at > now()',
+ undef, $event, $filename);
+ if (defined($ref)) {
+ ($fname, $size, $mtime) = Sesse::pr0n::Common::stat_image_from_id($r, $ref->{'id'});
+ }
+ } elsif (!defined($fname)) {
+ ($fname, $size, $mtime) = Sesse::pr0n::Common::stat_image($r, $event, $filename);
+ }
+ }
+
+ if (!defined($fname)) {
+ $r->status(404);
+ $r->content_type('text/plain; charset=utf-8');
+ $r->print("Couldn't find file");
+ return Apache2::Const::OK;
+ }
+
+ $r->status(200);
+ $r->set_content_length($size);
+ $r->set_last_modified($mtime);
+
+ if ($r->method eq "GET") {
+ $r->sendfile($fname);
+ }
+ return Apache2::Const::OK;
+ }
+
+ 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;
+ }
+
+ my ($event, $autorename, $filename) = ($1, $2, $3);
+ my $size = $r->headers_in->{'content-length'};
+ my $orig_filename = $filename;
+
+ # Remove evil characters
+ if ($filename =~ /[^a-zA-Z0-9._-]/) {
+ 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;
+ }
+ }
+
+ #
+ # gnome-vfs and mac os x love to make zero-byte files,
+ # make them happy
+ #
+ if ($r->headers_in->{'content-length'} == 0) {
+ $dbh->do('DELETE FROM fake_files WHERE expires_at <= now() OR (event=? AND filename=?);',
+ undef, $event, $filename)
+ or dberror($r, "Couldn't prune fake_files");
+ $dbh->do('INSERT INTO fake_files (event,filename,expires_at) VALUES (?,?,now() + interval \'30 seconds\');',
+ undef, $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;
+ }
+
+ # 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");
+ }
+
+ # Autorename if we need to
+ if (defined($autorename) && $autorename eq "autorename/") {
+ my $ref = $dbh->selectrow_hashref("SELECT COUNT(*) AS numfiles FROM images WHERE event=? AND filename=?",
+ undef, $event, $filename)
+ or dberror($r, "Couldn't check for existing files");
+ if ($ref->{'numfiles'} > 0) {
+ $r->log->info("Renaming $filename to $newid.jpeg");
+ $filename = "$newid.jpeg";
+ }
+ }
+
+ {
+ # Enable transactions and error raising temporarily
+ local $dbh->{AutoCommit} = 0;
+
+ local $dbh->{RaiseError} = 1;
+
+ # Try to insert this new file
+ eval {
+ $dbh->do('DELETE FROM fake_files WHERE event=? AND filename=?;',
+ undef, $event, $filename);
+
+ $dbh->do('INSERT INTO images (id,event,uploadedby,takenby,filename) VALUES (?,?,?,?,?);',
+ undef, $newid, $event, $user, $takenby, $filename);
+
+ # Now save the file to disk
+ my $fname = Sesse::pr0n::Common::get_disk_location($r, $newid);
+ open NEWFILE, ">$fname"
+ or die "$fname: $!";
+
+ my $buf;
+ my $content_length = $r->headers_in->{'content-length'};
+ if ($r->read($buf, $content_length)) {
+ print NEWFILE $buf or die "write($fname): $!";
+ }
+
+ close NEWFILE or die "close($fname): $!";
+
+ # Orient stuff correctly
+ system("/usr/bin/exifautotran", $fname) == 0
+ or die "/usr/bin/exifautotran: $!";
+
+ # Make cache while we're at it.
+ # Don't do it for the resource forks Mac OS X loves to upload :-(
+ if ($filename !~ /^\._/) {
+ Sesse::pr0n::Common::ensure_cached($r, $filename, $newid, -1, -1, 1, 80, 64, 320, 256);
+ }
+
+ # OK, we got this far, commit
+ $dbh->commit;
+
+ $r->log->notice("Successfully wrote $event/$filename to $fname");
+ };
+ if ($@) {
+ # Some error occurred, rollback and bomb out
+ $dbh->rollback;
+ dberror($r, "Transaction aborted because $@");
+ }
+ }
+
+ # Insert a `shadow file' we can stat the next 30 secs
+ if (defined($autorename) && $autorename eq "autorename/") {
+ $dbh->do('DELETE FROM shadow_files WHERE expires_at <= now() OR (event=? AND filename=?);',
+ undef, $event, $filename)
+ or dberror($r, "Couldn't prune shadow_files");
+ $dbh->do('INSERT INTO shadow_files (event,filename,id,expires_at) VALUES (?,?,?,now() + interval \'30 seconds\');',
+ undef, $event, $orig_filename, $newid)
+ or dberror($r, "Couldn't add shadow file");
+ $r->log->info("Added shadow entry for $event/$filename");
+ }
+
+ $r->content_type('text/plain; charset="utf-8"');
+ $r->status(201);
+ $r->print("OK");
+
+ return Apache2::Const::OK;
+ }
+
+ # 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;
+ }
+
+ my ($event, $autorename, $filename) = ($1, $2, $3);
+ my $sha1 = Digest::SHA1::sha1_base64("/$event/$autorename/$filename");
+
+ $r->status(200);
+ $r->content_type('text/xml; charset=utf-8');
+
+ $r->print(<<"EOF");
+
+
+
+
+
+
+ 0
+
+ /webdav/upload/$event/$autorename$filename
+
+ Second-3600
+
+ opaquelocktoken:$sha1
+
+
+
+
+EOF
+ return Apache2::Const::OK;
+ }
+
+ if ($r->method eq "UNLOCK") {
+ $r->content_type('text/plain; charset="utf-8"');
+ $r->status(200);
+ $r->print("OK");
+
+ return Apache2::Const::OK;
+ }
+
+ 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;
+ }
+
+ my ($event, $autorename, $filename) = ($1, $2, $3);
+ $dbh->do('DELETE FROM images WHERE event=? AND filename=?;',
+ undef, $event, $filename)
+ or dberror($r, "Couldn't remove file");
+ $r->status(200);
+ $r->print("OK");
+
+ $r->log->info("deleted $event/$filename");
+
+ return Apache2::Const::OK;
+ }
+
+ if ($r->method eq "MOVE" or
+ $r->method eq "MKCOL" 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;
+ }
+
+ $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;
+}
+
+1;
+
+
diff --git a/perl/Sesse/pr0n/pr0n.pm b/perl/Sesse/pr0n/pr0n.pm
new file mode 100644
index 0000000..620bf19
--- /dev/null
+++ b/perl/Sesse/pr0n/pr0n.pm
@@ -0,0 +1,63 @@
+use Sesse::pr0n::Common;
+use Sesse::pr0n::Listing;
+use Sesse::pr0n::Index;
+use Sesse::pr0n::Image;
+use Sesse::pr0n::Single;
+use Sesse::pr0n::Rotate;
+use Sesse::pr0n::Select;
+use Sesse::pr0n::WebDAV;
+use Sesse::pr0n::NewEvent;
+
+package Sesse::pr0n::pr0n;
+use strict;
+use warnings;
+
+sub handler {
+ my $r = shift;
+
+ my $uri = $r->uri;
+ if ($uri eq '/') {
+ return Sesse::pr0n::Listing::handler($r);
+ } elsif ($uri eq '/robots.txt' ||
+ $uri eq '/pr0n.css' ||
+ $uri eq '/skoyen.css' ||
+ $uri eq '/blah.png' ||
+ $uri eq '/faq.html' ||
+ $uri =~ m#^/usage/([a-zA-Z0-9_.]+)$#) {
+ $uri =~ s#^/##;
+ $r->content_type(Sesse::pr0n::Common::get_mimetype_from_filename($uri));
+ $r->sendfile(Sesse::pr0n::Common::get_base($r) . $uri);
+ return Apache2::Const::OK;
+ } elsif ($uri eq '/newevent.html') {
+ $r->content_type('text/html; charset=utf-8');
+ $r->sendfile(Sesse::pr0n::Common::get_base($r) . "newevent.html");
+ return Apache2::Const::OK;
+ } 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;
+ } elsif ($uri =~ m#^/single/?$#) {
+ return Sesse::pr0n::Single::handler($r);
+ } elsif ($uri =~ m#^/rotate$#) {
+ return Sesse::pr0n::Rotate::handler($r);
+ } elsif ($uri =~ m#^/select$#) {
+ return Sesse::pr0n::Select::handler($r);
+ } elsif ($uri =~ m#^/newevent$#) {
+ return Sesse::pr0n::NewEvent::handler($r);
+ } elsif ($uri =~ m#^/[a-zA-Z0-9-]+/?$#) {
+ return Sesse::pr0n::Index::handler($r);
+ } elsif ($uri =~ m#^/[a-zA-Z0-9-]+/(\d+x\d+/)?(nobox/)?[a-zA-Z0-9._-]+$#) {
+ 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;
+}
+
+1;
+
+
diff --git a/pr0n.css b/pr0n.css
new file mode 100644
index 0000000..4d4c6ba
--- /dev/null
+++ b/pr0n.css
@@ -0,0 +1,19 @@
+body {
+ background-color: white;
+ color: black;
+ font-family: verdana, arial, helvetica, sans-serif;
+ font-size: smaller;
+}
+a {
+ text-decoration: none;
+}
+.footer {
+ font-size: smaller;
+ margin-top: 0;
+}
+h2.date {
+ font-size: 1em;
+}
+img {
+ border: 1px solid black;
+}
diff --git a/robots.txt b/robots.txt
new file mode 100644
index 0000000..c6742d8
--- /dev/null
+++ b/robots.txt
@@ -0,0 +1,2 @@
+User-Agent: *
+Disallow: /
diff --git a/skoyen.css b/skoyen.css
new file mode 100644
index 0000000..ce70bd6
--- /dev/null
+++ b/skoyen.css
@@ -0,0 +1,50 @@
+td, body, p, div {
+ font-family: verdana,helvetica;
+ font-size: 10px;
+}
+
+/* The content of the posts (body of text) */
+body {
+ background: #fcfcfc;
+ color: #000000;
+ font: 12px verdana,arial,helvetica,sans-serif;
+ scrollbar-3dlight-color: #d1d7dc;
+ scrollbar-arrow-color: #006699;
+ scrollbar-darkshadow-color: #98aab1;
+ scrollbar-face-color: #dee3e7;
+ scrollbar-highlight-color: #ffffff;
+ scrollbar-shadow-color: #dee3e7;
+ scrollbar-track-color: #efefef;
+}
+
+/* General page style */
+a:link,a:active,a:visited,a.postlink {
+ color: #006699;
+ text-decoration: underline;
+}
+a:hover {
+ color: #dd6900;
+ text-decoration: none;
+}
+
+/* This is the border line & background colour round the entire page */
+.bodyline {
+ background: #ffffff;
+ border: 1px solid #98aab1;
+}
+
+/* Form elements */
+select, input, textarea {
+ border-color: #006699;
+ color: #000000;
+ font: normal 10px Verdana,Arial,Helvetica,sans-serif;
+}
+input {
+ background-color: #FCFCFC /* url(images/navbar.jpg) */;
+ border-width: 1px;
+}
+textarea {
+ background-color: #FCFCFC;
+ border-width: 1px;
+}
+
diff --git a/templates/bilder.knatten.com/date b/templates/bilder.knatten.com/date
new file mode 100644
index 0000000..1de41ba
--- /dev/null
+++ b/templates/bilder.knatten.com/date
@@ -0,0 +1,3 @@
+ Dato: %DATE%
+
+
diff --git a/templates/bilder.knatten.com/event-listing b/templates/bilder.knatten.com/event-listing
new file mode 100644
index 0000000..7ab4369
--- /dev/null
+++ b/templates/bilder.knatten.com/event-listing
@@ -0,0 +1 @@
+Bildegalleri
diff --git a/templates/bilder.knatten.com/footer b/templates/bilder.knatten.com/footer
new file mode 100644
index 0000000..533b320
--- /dev/null
+++ b/templates/bilder.knatten.com/footer
@@ -0,0 +1,8 @@
+
+
+
+