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.

+ +
+

pr0n v2.04, + © 2004-2006 Steinar H. Gunderson.

+ + 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. :-)

+ +
+

ID: (f.eks. "revy03", må kun inneholde a-zA-Z0-9 og -, ingen mellomrom)

+

Dato: (f.eks. "27.-31. desember 2003")

+

Beskrivelse: (f.eks. "Nyttårsrevyen 2003")

+

+
+ + 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"); + + while (my $ref = $q->fetchrow_hashref()) { + my $imgsz = ""; + my $takenby = $ref->{'takenby'}; + if (defined($ref->{'day'})) { + $takenby .= ", " . $ref->{'day'}; + } + + if ($takenby ne $lastupl) { + $lastupl = $takenby; + Sesse::pr0n::Templates::print_template($r, "submittedby", { author => $lastupl }); + } + 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("

\"\"$imgsz\n"); + $r->print(" 90 {'id'} . "-90\" />\n"); + $r->print(" 180 {'id'} . "-180\" />\n"); + $r->print(" 270 {'id'} . "-270\" />\n"); + $r->print("        " . + "     Del {'id'} . "\" />

\n"); + } + $r->print(" \n"); + $r->print("
\n"); + } elsif ($sel == 1) { + $r->print("
\n"); + $r->print(" \n"); + + while (my $ref = $q->fetchrow_hashref()) { + my $imgsz = ""; + my $takenby = $ref->{'takenby'}; + if (defined($ref->{'day'})) { + $takenby .= ", " . $ref->{'day'}; + } + + if ($takenby ne $lastupl) { + $lastupl = $takenby; + Sesse::pr0n::Templates::print_template($r, "submittedby", { author => $lastupl }); + } + 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"; + } + + my $selected = $ref->{'selected'} ? ' checked="checked"' : ''; + + $r->print("

\"\"$imgsz\n"); + $r->print(" {'id'} . "\"$selected />

\n"); + } + $r->print(" \n"); + $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(" \"\"$imgsz\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"); + 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'} =