From: Steinar H. Gunderson Last updated July 16th, 2006 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). 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. 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. 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. 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. 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 :-) 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. 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. 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.) 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. 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). 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 ;-) Try e-mail, or reach me
+ on IRC as Sesse on EFnet, IRCnet, Freenode or OFTC. 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. :-) Error: $errpr0n FAQ
+ So, what is this pr0n thing anyway?
+
+ Why the name? Is this some kind of fetish site?
+
+ Can I upload my own images here?
+
+ Can I download all the pictures for viewing?
+
+ I just changed thumbnail resolution, why is everything so slow?
+
+ Why didn't you just throw up Gallery?
+
+ What are the primary features of pr0n?
+
+ What hardware/software does it run on?
+
+ How much data is there in there, anyway?
+
+ Can I get the source?
+
+ Will you implement feature X?
+
+ Is the upload WebDAV server RFC-compliant?
+
+ How do I get in touch with you?
+
+
+
+
+
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
+
+
\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("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"); + +Couldn'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"); + +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 @@ +