X-Git-Url: https://git.sesse.net/?p=pr0n;a=blobdiff_plain;f=perl%2FSesse%2Fpr0n%2FCommon.pm;h=14ae88b40664c29f8f39a2f0595580f950325962;hp=9a3d31cc34e9eecaf737315285d3b232b6346eab;hb=238c9466b74b540cedc7569ca3d81a9de911c225;hpb=a1ed3a66ce503c2b6c2d177f9ab36a148375e0d4 diff --git a/perl/Sesse/pr0n/Common.pm b/perl/Sesse/pr0n/Common.pm index 9a3d31c..14ae88b 100644 --- a/perl/Sesse/pr0n/Common.pm +++ b/perl/Sesse/pr0n/Common.pm @@ -2,8 +2,9 @@ package Sesse::pr0n::Common; use strict; use warnings; -use Sesse::pr0n::Templates; use Sesse::pr0n::Overload; +use Sesse::pr0n::QscaleProxy; +use Sesse::pr0n::Templates; use Apache2::RequestRec (); # for $r->content_type use Apache2::RequestIO (); # for $r->print @@ -25,6 +26,7 @@ use LWP::Simple; use Image::ExifTool; use HTML::Entities; use URI::Escape; +use File::Basename; BEGIN { use Exporter (); @@ -35,7 +37,7 @@ BEGIN { require Sesse::pr0n::Config_local; }; - $VERSION = "v2.60"; + $VERSION = "v2.70"; @ISA = qw(Exporter); @EXPORT = qw(&error &dberror); %EXPORT_TAGS = qw(); @@ -218,10 +220,12 @@ sub get_cache_location { my ($r, $id, $width, $height, $infobox) = @_; my $dir = POSIX::floor($id / 256); - if ($infobox) { + if ($infobox eq 'both') { return get_base($r) . "cache/$dir/$id-$width-$height.jpg"; - } else { + } elsif ($infobox eq 'nobox') { return get_base($r) . "cache/$dir/$id-$width-$height-nobox.jpg"; + } else { + return get_base($r) . "cache/$dir/$id-$width-$height-box.png"; } } @@ -308,19 +312,34 @@ sub update_image_info { sub check_access { my $r = shift; + + #return qw(sesse Sesse); 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"); + if (!defined($auth)) { + output_401($r); return undef; } - - #return qw(sesse Sesse); + if ($auth =~ /^Basic ([a-zA-Z0-9+\/]+=*)$/) { + return check_basic_auth($r, $1); + } + output_401($r); + return undef; +} + +sub output_401 { + my $r = shift; + $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"); +} + +sub check_basic_auth { + my ($r, $auth) = @_; + + my ($user, $pass) = split /:/, MIME::Base64::decode_base64($auth); - my ($user, $pass) = split /:/, MIME::Base64::decode_base64($1); # WinXP is stupid :-) if ($user =~ /^.*\\(.*)$/) { $user = $1; @@ -340,11 +359,8 @@ sub check_access { 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"); + output_401($r); return undef; } @@ -377,12 +393,14 @@ sub stat_image_from_id { # Takes in an image ID and a set of resolutions, and returns (generates if needed) # the smallest mipmap larger than the largest of them. sub make_mipmap { - my ($r, $filename, $id, $dbwidth, $dbheight, @res) = @_; + my ($r, $filename, $id, $dbwidth, $dbheight, $can_use_qscale, @res) = @_; my ($img, $mmimg, $width, $height); + + my $physical_fname = get_disk_location($r, $id); # If we don't know the size, we'll need to read it in anyway if (!defined($dbwidth) || !defined($dbheight)) { - $img = read_original_image($r, $id, $dbwidth, $dbheight); + $img = read_original_image($r, $filename, $id, $dbwidth, $dbheight, $can_use_qscale); $width = $img->Get('columns'); $height = $img->Get('rows'); } else { @@ -406,7 +424,7 @@ sub make_mipmap { my $large_enough = 1; for my $i (0..($#res/2)) { my ($xres, $yres) = ($res[$i*2], $res[$i*2+1]); - if ($xres > $new_mmwidth || $yres > $new_mmheight) { + if ($xres == -1 || $xres > $new_mmwidth || $yres > $new_mmheight) { $large_enough = 0; last; } @@ -419,7 +437,7 @@ sub make_mipmap { push @mmlist, [ $mmwidth, $mmheight ]; } - + # Ensure that all of them are OK my $last_good_mmlocation; for my $i (0..$#mmlist) { @@ -427,13 +445,17 @@ sub make_mipmap { my $mmres = $mmlist[$i]; my $mmlocation = get_mipmap_location($r, $id, $mmres->[0], $mmres->[1]); - if (! -r $mmlocation or (-M $mmlocation > -M $filename)) { + if (! -r $mmlocation or (-M $mmlocation > -M $physical_fname)) { if (!defined($img)) { if (defined($last_good_mmlocation)) { - $img = Image::Magick->new; + if ($can_use_qscale) { + $img = Sesse::pr0n::QscaleProxy->new; + } else { + $img = Image::Magick->new; + } $img->Read($last_good_mmlocation); } else { - $img = read_original_image($r, $id, $dbwidth, $dbheight); + $img = read_original_image($r, $filename, $id, $dbwidth, $dbheight, $can_use_qscale); } } my $cimg; @@ -443,7 +465,7 @@ sub make_mipmap { $cimg = $img->Clone(); } $r->log->info("Making mipmap for $id: " . $mmres->[0] . " x " . $mmres->[1]); - $cimg->Resize(width=>$mmres->[0], height=>$mmres->[1], filter=>'Lanczos'); + $cimg->Resize(width=>$mmres->[0], height=>$mmres->[1], filter=>'Lanczos', 'sampling-factor'=>'1x1'); $cimg->Strip(); my $err = $cimg->write( filename => $mmlocation, @@ -456,31 +478,43 @@ sub make_mipmap { } if ($last && !defined($img)) { # OK, read in the smallest one - $img = Image::Magick->new; + if ($can_use_qscale) { + $img = Sesse::pr0n::QscaleProxy->new; + } else { + $img = Image::Magick->new; + } my $err = $img->Read($mmlocation); } } + if (!defined($img)) { + $img = read_original_image($r, $filename, $id, $dbwidth, $dbheight, $can_use_qscale); + } return $img; } sub read_original_image { - my ($r, $id, $dbwidth, $dbheight) = @_; + my ($r, $filename, $id, $dbwidth, $dbheight, $can_use_qscale) = @_; - my $fname = get_disk_location($r, $id); + my $physical_fname = get_disk_location($r, $id); # Read in the original image - my $magick = new Image::Magick; + my $magick; + if ($can_use_qscale && ($filename =~ /\.jpeg$/i || $filename =~ /\.jpg$/i)) { + $magick = Sesse::pr0n::QscaleProxy->new; + } else { + $magick = Image::Magick->new; + } my $err; # ImageMagick can handle NEF files, but it does it by calling dcraw as a delegate. # The delegate support is rather broken and causes very odd stuff to happen when # more than one thread does this at the same time. Thus, we simply do it ourselves. - if ($fname =~ /\.nef$/i) { + if ($filename =~ /\.(nef|cr2)$/i) { # this would suffice if ImageMagick gets to fix their handling - # $fname = "NEF:$fname"; + # $physical_fname = "NEF:$physical_fname"; - open DCRAW, "-|", "dcraw", "-w", "-c", $fname + open DCRAW, "-|", "dcraw", "-w", "-c", $physical_fname or error("dcraw: $!"); $err = $magick->Read(file => \*DCRAW); close(DCRAW); @@ -494,20 +528,25 @@ sub read_original_image { #if (!$infobox) { # $magick->Set(colorspace=>'YCbCr'); #} - $err = $magick->Read($fname); + $err = $magick->Read($physical_fname); } if ($err) { - $r->log->warn("$fname: $err"); + $r->log->warn("$physical_fname: $err"); $err =~ /(\d+)/; if ($1 >= 400) { undef $magick; - error($r, "$fname: $err"); + error($r, "$physical_fname: $err"); } } # If we use ->[0] unconditionally, text rendering (!) seems to crash - my $img = (scalar @$magick > 1) ? $magick->[0] : $magick; + my $img; + if (ref($magick)) { + $img = $magick; + } else { + $img = (scalar @$magick > 1) ? $magick->[0] : $magick; + } my $width = $img->Get('columns'); my $height = $img->Get('rows'); @@ -525,8 +564,10 @@ sub ensure_cached { my ($r, $filename, $id, $dbwidth, $dbheight, $infobox, $xres, $yres, @otherres) = @_; my $fname = get_disk_location($r, $id); - unless (defined($xres) && (!defined($dbwidth) || !defined($dbheight) || $xres < $dbheight || $yres < $dbwidth || $xres == -1)) { - return ($fname, 0); + if ($infobox ne 'box') { + unless (defined($xres) && (!defined($dbwidth) || !defined($dbheight) || $xres < $dbheight || $yres < $dbwidth || $xres == -1)) { + return ($fname, undef); + } } my $cachename = get_cache_location($r, $id, $xres, $yres, $infobox); @@ -538,8 +579,64 @@ sub ensure_cached { $r->log->warn("In overload mode, not scaling $id to $xres x $yres"); error($r, 'System is in overload mode, not doing any scaling'); } - - my $img = make_mipmap($r, $fname, $id, $dbwidth, $dbheight, $xres, $yres, @otherres); + + # If we're being asked for just the box, make a new image with just the box. + # We don't care about @otherres since each of these images are + # already pretty cheap to generate, but we need the exact width so we can make + # one in the right size. + if ($infobox eq 'box') { + my ($img, $width, $height); + + # This is slow, but should fortunately almost never happen, so don't bother + # special-casing it. + if (!defined($dbwidth) || !defined($dbheight)) { + $img = read_original_image($r, $filename, $id, $dbwidth, $dbheight, 0); + $width = $img->Get('columns'); + $height = $img->Get('rows'); + @$img = (); + } else { + $img = Image::Magick->new; + $width = $dbwidth; + $height = $dbheight; + } + + if (defined($xres) && defined($yres)) { + ($width, $height) = scale_aspect($width, $height, $xres, $yres); + } + $height = 24; + $img->Set(size=>($width . "x" . $height)); + $img->Read('xc:white'); + + my $info = Image::ExifTool::ImageInfo($fname); + if (make_infobox($img, $info, $r)) { + $img->Quantize(colors=>16, dither=>'False'); + + # Since the image is grayscale, ImageMagick overrides us and writes this + # as grayscale anyway, but at least we get rid of the alpha channel this + # way. + $img->Set(type=>'Palette'); + } else { + # Not enough room for the text, make a tiny dummy transparent infobox + @$img = (); + $img->Set(size=>"1x1"); + $img->Read('null:'); + + $width = 1; + $height = 1; + } + + $err = $img->write(filename => $cachename, quality => 90, depth => 8); + $r->log->info("New infobox cache: $width x $height for $id.jpg"); + + return ($cachename, 'image/png'); + } + + my $can_use_qscale = 0; + if ($infobox eq 'nobox') { + $can_use_qscale = 1; + } + + my $img = make_mipmap($r, $filename, $id, $dbwidth, $dbheight, $can_use_qscale, $xres, $yres, @otherres); while (defined($xres) && defined($yres)) { my ($nxres, $nyres) = (shift @otherres, shift @otherres); @@ -570,10 +667,10 @@ sub ensure_cached { } if ($xres != -1) { - $cimg->Resize(width=>$nwidth, height=>$nheight, filter=>$filter); + $cimg->Resize(width=>$nwidth, height=>$nheight, filter=>$filter, 'sampling-factor'=>$sf); } - if (($nwidth >= 800 || $nheight >= 600 || $xres == -1) && $infobox == 1) { + if (($nwidth >= 800 || $nheight >= 600 || $xres == -1) && $infobox ne 'nobox') { my $info = Image::ExifTool::ImageInfo($fname); make_infobox($cimg, $info, $r); } @@ -613,7 +710,7 @@ sub ensure_cached { } } } - return ($cachename, 1); + return ($cachename, 'image/jpeg'); } sub get_mimetype_from_filename { @@ -638,7 +735,7 @@ sub make_infobox { $info->{'ExposureProgram'} =~ /aperture\b.*\bpriority/i); my @classic_fields = (); - if (defined($info->{'FocalLength'}) && $info->{'FocalLength'} =~ /^(\d+)(?:\.\d+)?(?:mm)?$/) { + if (defined($info->{'FocalLength'}) && $info->{'FocalLength'} =~ /^(\d+)(?:\.\d+)?\s*(?:mm)?$/) { push @classic_fields, [ $1 . "mm", 0 ]; } elsif (defined($info->{'FocalLength'}) && $info->{'FocalLength'} =~ /^(\d+)\/(\d+)$/) { push @classic_fields, [ (sprintf "%.1fmm", ($1/$2)), 0 ]; @@ -648,7 +745,7 @@ sub make_infobox { my ($a, $b) = ($1, $2); my $gcd = gcd($a, $b); push @classic_fields, [ $a/$gcd . "/" . $b/$gcd . "s", $shutter_priority ]; - } elsif (defined($info->{'ExposureTime'}) && $info->{'ExposureTime'} =~ /^(\d+)$/) { + } elsif (defined($info->{'ExposureTime'}) && $info->{'ExposureTime'} =~ /^(\d+(?:\.\d+))$/) { push @classic_fields, [ $1 . "s", $shutter_priority ]; } @@ -735,7 +832,7 @@ sub make_infobox { } } - return if (scalar @parts == 0); + return 0 if (scalar @parts == 0); # Find the required width my $th = 0; @@ -755,7 +852,7 @@ sub make_infobox { $th = $h if ($h > $th); } - return if ($tw > $img->Get('columns')); + return 0 if ($tw > $img->Get('columns')); my $x = 0; my $y = $img->Get('rows') - 24; @@ -784,6 +881,8 @@ sub make_infobox { $img->Annotate(text=>$part->[0], font=>$font, pointsize=>12, x=>int($x), y=>int($y)); $x += ($img->QueryFontMetrics(text=>$part->[0], font=>$font, pointsize=>12))[4]; } + + return 1; } sub gcd { @@ -793,7 +892,7 @@ sub gcd { } sub add_new_event { - my ($dbh, $id, $date, $desc, $vhost) = @_; + my ($r, $dbh, $id, $date, $desc) = @_; my @errors = (); if (!defined($id) || $id =~ /^\s*$/ || $id !~ /^([a-zA-Z0-9-]+)$/) { @@ -810,12 +909,14 @@ sub add_new_event { return @errors; } + my $vhost = $r->get_server_name; $dbh->do("INSERT INTO events (event,date,name,vhost) VALUES (?,?,?,?)", undef, $id, $date, $desc, $vhost) or return ("Kunne ikke sette inn ny hendelse" . $dbh->errstr); $dbh->do("INSERT INTO last_picture_cache (vhost,event,last_picture) VALUES (?,?,NULL)", undef, $vhost, $id) or return ("Kunne ikke sette inn ny cache-rad" . $dbh->errstr); + purge_cache($r, "/"); return (); } @@ -834,6 +935,69 @@ sub guess_charset { return $decoded; } +# Depending on your front-end cache, you might want to get creative somehow here. +# This example assumes you have a front-end cache and it can translate an X-Pr0n-Purge +# regex tacked onto a request into something useful. The elements given in +# should not be regexes, though, as e.g. Squid will not be able to handle that. +sub purge_cache { + my ($r, @elements) = @_; + return if (scalar @elements == 0); + + my @pe = (); + for my $elem (@elements) { + $r->log->info("Purging $elem"); + (my $e = $elem) =~ s/[.+*|()]/\\$&/g; + push @pe, $e; + } + + my $regex = "^"; + if (scalar @pe == 1) { + $regex .= $pe[0]; + } else { + $regex .= "(" . join('|', @pe) . ")"; + } + $regex .= "(\\?.*)?\$"; + $r->headers_out->{'X-Pr0n-Purge'} = $regex; + + $r->log->info($r->headers_out->{'X-Pr0n-Purge'}); +} + +# Find a list of all cache URLs for a given image, given what we have on disk. +sub get_all_cache_urls { + my ($r, $dbh, $id) = @_; + my $dir = POSIX::floor($id / 256); + my @ret = (); + + my $q = $dbh->prepare('SELECT event, filename FROM images WHERE id=?') + or die "Couldn't prepare: " . $dbh->errstr; + $q->execute($id) + or die "Couldn't find event and filename: " . $dbh->errstr; + my $ref = $q->fetchrow_hashref; + my $event = $ref->{'event'}; + my $filename = $ref->{'filename'}; + $q->finish; + + my $base = get_base($r) . "cache/$dir"; + for my $file (<$base/$id-*>) { + my $fname = File::Basename::basename($file); + if ($fname =~ /^$id-mipmap-.*\.jpg$/) { + # Mipmaps don't have an URL, ignore + } elsif ($fname =~ /^$id--1--1\.jpg$/) { + push @ret, "/$event/$filename"; + } elsif ($fname =~ /^$id-(\d+)-(\d+)\.jpg$/) { + push @ret, "/$event/$1x$2/$filename"; + } elsif ($fname =~ /^$id-(\d+)-(\d+)-nobox\.jpg$/) { + push @ret, "/$event/$1x$2/nobox/$filename"; + } elsif ($fname =~ /^$id-(\d+)-(\d+)-box\.png$/) { + push @ret, "/$event/$1x$2/box/$filename"; + } else { + $r->log->warning("Couldn't find a purging URL for $fname"); + } + } + + return @ret; +} + 1;