X-Git-Url: https://git.sesse.net/?p=pr0n;a=blobdiff_plain;f=perl%2FSesse%2Fpr0n%2FCommon.pm;h=77cf431a977dbc598e28df9fa2f4336ecb36f8e6;hp=828df6a91466a4b9883e92b5d469efe4baa2a07d;hb=acc5b53241d0e971595d6017c60f54a6bc057c41;hpb=04cab7c72227c290224ab0c0b0a52c0893516552

diff --git a/perl/Sesse/pr0n/Common.pm b/perl/Sesse/pr0n/Common.pm
index 828df6a..77cf431 100644
--- a/perl/Sesse/pr0n/Common.pm
+++ b/perl/Sesse/pr0n/Common.pm
@@ -19,7 +19,7 @@ use DBD::Pg;
 use Image::Magick;
 use POSIX;
 use Digest::MD5;
-use Digest::SHA1;
+use Digest::SHA;
 use Digest::HMAC_SHA1;
 use MIME::Base64;
 use MIME::Types;
@@ -29,6 +29,7 @@ use Image::ExifTool;
 use HTML::Entities;
 use URI::Escape;
 use File::Basename;
+use Crypt::Eksblowfish::Bcrypt;
 
 BEGIN {
 	use Exporter ();
@@ -39,7 +40,7 @@ BEGIN {
 		require Sesse::pr0n::Config_local;
 	};
 
-	$VERSION     = "v2.70";
+	$VERSION     = "v2.81";
 	@ISA         = qw(Exporter);
 	@EXPORT      = qw(&error &dberror);
 	%EXPORT_TAGS = qw();
@@ -96,7 +97,7 @@ sub header {
 		$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 => Encode::decode_utf8($quote) });
+	Sesse::pr0n::Templates::print_template($r, "header", { title => $title, quotes => $quote });
 }
 
 sub footer {
@@ -211,7 +212,7 @@ sub get_base {
 	my $r = shift;
 	return $r->dir_config('ImageBase');
 }
-
+				
 sub get_disk_location {
 	my ($r, $id) = @_;
         my $dir = POSIX::floor($id / 256);
@@ -219,7 +220,7 @@ sub get_disk_location {
 }
 
 sub get_cache_location {
-	my ($r, $id, $width, $height, $infobox) = @_;
+	my ($r, $id, $width, $height, $infobox, $dpr) = @_;
         my $dir = POSIX::floor($id / 256);
 
 	if ($infobox eq 'both') {
@@ -227,7 +228,28 @@ sub get_cache_location {
 	} 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";
+		if ($dpr == 1) {
+			return get_base($r) . "cache/$dir/$id-$width-$height-box.png";
+		} else {
+			return get_base($r) . "cache/$dir/$id-$width-$height-box\@$dpr.png";
+		}
+	}
+}
+
+sub ensure_disk_location_exists {
+	my ($r, $id) = @_;
+	my $dir = POSIX::floor($id / 256);
+
+	my $img_dir = get_base($r) . "/images/$dir/";
+	if (! -d $img_dir) {
+		$r->log->info("Need to create new image directory $img_dir");
+		mkdir($img_dir) or die "Couldn't create new image directory $img_dir";
+	}
+
+	my $cache_dir = get_base($r) . "/cache/$dir/";
+	if (! -d $cache_dir) {
+		$r->log->info("Need to create new cache directory $cache_dir");
+		mkdir($cache_dir) or die "Couldn't create new image directory $cache_dir";
 	}
 }
 
@@ -291,6 +313,10 @@ sub update_image_info {
 		
 		# Tags
 		my @tags = $exiftool->GetValue('Keywords', 'ValueConv');
+		if (scalar @tags == 0) {
+			# This is XMP-dc:Subject, an RDF bag of tags.
+			@tags = $exiftool->GetValue('Subject', 'ValueConv');
+		}
 		$dbh->do('DELETE FROM tags WHERE image=?',
 			undef, $id)
 			or die "Couldn't delete old tag information in SQL: $!";
@@ -306,7 +332,7 @@ sub update_image_info {
 
 		# update the last_picture cache as well (this should of course be done
 		# via a trigger, but this is less complicated :-) )
-		$dbh->do('UPDATE last_picture_cache SET last_picture=GREATEST(last_picture, ?) WHERE (vhost,event)=(SELECT vhost,event FROM images WHERE id=?)',
+		$dbh->do('UPDATE last_picture_cache SET last_picture=GREATEST(last_picture, ?),last_update=CURRENT_TIMESTAMP WHERE (vhost,event)=(SELECT vhost,event FROM images WHERE id=?)',
 			undef, $datetime, $id)
 			or die "Couldn't update last_picture in SQL: $!";
 	}
@@ -338,18 +364,19 @@ sub output_401 {
 	$r->status(401);
 	$r->headers_out->{'www-authenticate'} = 'Basic realm="pr0n.sesse.net"';
 
-	if ($options{'DigestAuth'} // 1) {
+	# Digest auth is disabled for now, due to various client problems.
+	if (0 && ($options{'DigestAuth'} // 1)) {
 		# We make our nonce similar to the scheme of RFC2069 section 2.1.1,
 		# with some changes: We don't care about client IP (these have a nasty
 		# tendency to change from request to request when load-balancing
 		# proxies etc. are being used), and we use HMAC instead of simple
 		# hashing simply because that's a better signing method.
 		#
-		# NOTE: For some weird reason, Digest::HMAC_SHA1 doesn't like taking
+		# NOTE: For some weird reason, Digest::HMAC_SHA doesn't like taking
 		# the output from time directly (it gives a different response), so we
 		# forcefully stringify the argument.
 		my $ts = time;
-		my $nonce = Digest::HMAC_SHA1->hmac_sha1_hex($ts . "", $Sesse::pr0n::Config::db_password);
+		my $nonce = Digest::HMAC_SHA->hmac_sha1_hex($ts . "", $Sesse::pr0n::Config::db_password);
 		my $stale_nonce_text = "";
 		$stale_nonce_text = ", stale=\"true\"" if ($options{'StaleNonce'} // 0);
 
@@ -368,10 +395,18 @@ sub check_basic_auth {
 
 	my ($raw_user, $pass) = split /:/, MIME::Base64::decode_base64($auth);
 	my ($user, $takenby) = extract_takenby($raw_user);
-	
-	my $ref = $dbh->selectrow_hashref('SELECT sha1password,digest_ha1_hex FROM users WHERE username=? AND vhost=?',
+
+	my $ref = $dbh->selectrow_hashref('SELECT sha1password,cryptpassword,digest_ha1_hex FROM users WHERE username=? AND vhost=?',
 		undef, $user, $r->get_server_name);
-	if (!defined($ref) || $ref->{'sha1password'} ne Digest::SHA1::sha1_base64($pass)) {
+	my ($sha1_matches, $bcrypt_matches) = (0, 0);
+	if (defined($ref) && defined($ref->{'sha1password'})) {
+		$sha1_matches = (Digest::SHA::sha1_base64($pass) eq $ref->{'sha1password'});
+	}
+	if (defined($ref) && defined($ref->{'cryptpassword'})) {
+		$bcrypt_matches = (Crypt::Eksblowfish::Bcrypt::bcrypt($pass, $ref->{'cryptpassword'}) eq $ref->{'cryptpassword'});
+	}
+
+	if (!defined($ref) || (!$sha1_matches && !$bcrypt_matches)) {
 		$r->content_type('text/plain; charset=utf-8');
 		$r->log->warn("Authentication failed for $user/$takenby");
 		output_401($r);
@@ -388,9 +423,39 @@ sub check_basic_auth {
 		$r->log->info("Updated Digest auth hash for for $user");
 	}
 
+	# Make sure we can use bcrypt authentication in the future with this password.
+	# Also remove old-style SHA1 password when we migrate.
+	if (!$bcrypt_matches) {
+		my $salt = get_pseudorandom_bytes(16);  # Doesn't need to be cryptographically secur.
+		my $hash = "\$2a\$07\$" . Crypt::Eksblowfish::Bcrypt::en_base64($salt);
+		my $cryptpassword = Crypt::Eksblowfish::Bcrypt::bcrypt($pass, $hash);
+		$dbh->do('UPDATE users SET sha1password=NULL,cryptpassword=? WHERE username=? AND vhost=?',
+			undef, $cryptpassword, $user, $r->get_server_name)
+			or die "Couldn't update: " . $dbh->errstr;
+		$r->log->info("Updated bcrypt hash for $user");
+	}
+
 	return ($user, $takenby);
 }
 
+sub get_pseudorandom_bytes {
+	my $num_left = shift;
+	my $bytes = "";
+	open my $randfh, "<", "/dev/urandom"
+		or die "/dev/urandom: $!";
+	binmode $randfh;
+	while ($num_left > 0) {
+		my $tmp;
+		if (sysread($randfh, $tmp, $num_left) == -1) {
+			die "sysread(/dev/urandom): $!";
+		}
+		$bytes .= $tmp;
+		$num_left -= length($bytes);
+	}
+	close $randfh;
+	return $bytes;
+}
+
 sub check_digest_auth {
 	my ($r, $auth) = @_;	
 
@@ -531,7 +596,8 @@ 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.
+# the smallest mipmap larger than the largest of them, as well as the original image
+# dimensions.
 sub make_mipmap {
 	my ($r, $filename, $id, $dbwidth, $dbheight, $can_use_qscale, @res) = @_;
 	my ($img, $mmimg, $width, $height);
@@ -629,8 +695,10 @@ sub make_mipmap {
 
 	if (!defined($img)) {
 		$img = read_original_image($r, $filename, $id, $dbwidth, $dbheight, $can_use_qscale);
+		$width = $img->Get('columns');
+		$height = $img->Get('rows');
 	}
-	return $img;
+	return ($img, $width, $height);
 }
 
 sub read_original_image {
@@ -682,35 +750,28 @@ sub read_original_image {
 
 	# If we use ->[0] unconditionally, text rendering (!) seems to crash
 	my $img;
-	if (ref($magick)) {
+	if (ref($magick) !~ /Image::Magick/) {
 		$img = $magick;
 	} else {
 		$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 (!defined($dbwidth) || !defined($dbheight)) {
-		$r->log->info("Updating width/height for $id: $width x $height");
-		update_image_info($r, $id, $width, $height);
-	}
-
 	return $img;
 }
 
 sub ensure_cached {
-	my ($r, $filename, $id, $dbwidth, $dbheight, $infobox, $xres, $yres, @otherres) = @_;
+	my ($r, $filename, $id, $dbwidth, $dbheight, $infobox, $dpr, $xres, $yres, @otherres) = @_;
+
+	my ($new_dbwidth, $new_dbheight);
 
 	my $fname = get_disk_location($r, $id);
 	if ($infobox ne 'box') {
-		unless (defined($xres) && (!defined($dbwidth) || !defined($dbheight) || $xres < $dbheight || $yres < $dbwidth || $xres == -1)) {
+		unless (defined($xres) && (!defined($dbwidth) || !defined($dbheight) || $xres < $dbwidth || $yres < $dbheight || $xres == -1)) {
 			return ($fname, undef);
 		}
 	}
 
-	my $cachename = get_cache_location($r, $id, $xres, $yres, $infobox);
+	my $cachename = get_cache_location($r, $id, $xres, $yres, $infobox, $dpr);
 	my $err;
 	if (! -r $cachename or (-M $cachename > -M $fname)) {
 		# If we are in overload mode (aka Slashdot mode), refuse to generate
@@ -731,8 +792,8 @@ sub ensure_cached {
 			# 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');
+				$new_dbwidth = $width = $img->Get('columns');
+				$new_dbheight = $height = $img->Get('rows');
 				@$img = ();
 			} else {
 				$img = Image::Magick->new;
@@ -743,12 +804,12 @@ sub ensure_cached {
 			if (defined($xres) && defined($yres)) {
 				($width, $height) = scale_aspect($width, $height, $xres, $yres);
 			}
-			$height = 24;
+			$height = 24 * $dpr;
 			$img->Set(size=>($width . "x" . $height));
 			$img->Read('xc:white');
 				
 			my $info = Image::ExifTool::ImageInfo($fname);
-			if (make_infobox($img, $info, $r)) {
+			if (make_infobox($img, $info, $r, $dpr)) {
 				$img->Quantize(colors=>16, dither=>'False');
 
 				# Since the image is grayscale, ImageMagick overrides us and writes this
@@ -776,11 +837,12 @@ sub ensure_cached {
 			$can_use_qscale = 1;
 		}
 
-		my $img = make_mipmap($r, $filename, $id, $dbwidth, $dbheight, $can_use_qscale, $xres, $yres, @otherres);
+		my $img;
+		($img, $new_dbwidth, $new_dbheight) = 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);
-			my $cachename = get_cache_location($r, $id, $xres, $yres, $infobox);
+			my $cachename = get_cache_location($r, $id, $xres, $yres, $infobox, $dpr);
 			
 			my $cimg;
 			if (defined($nxres) && defined($nyres)) {
@@ -795,16 +857,9 @@ sub ensure_cached {
 			my $height = $img->Get('rows');
 			my ($nwidth, $nheight) = scale_aspect($width, $height, $xres, $yres);
 
-			# Use lanczos (sharper) for heavy scaling, mitchell (faster) otherwise
-			my $filter = 'Mitchell';
-			my $quality = 90;
-			my $sf = undef;
-
-			if ($width / $nwidth > 8.0 || $height / $nheight > 8.0) {
-				$filter = 'Lanczos';
-				$quality = 85;
-				$sf = "1x1";
-			}
+			my $filter = 'Lanczos';
+			my $quality = 87;
+			my $sf = "1x1";
 
 			if ($xres != -1) {
 				$cimg->Resize(width=>$nwidth, height=>$nheight, filter=>$filter, 'sampling-factor'=>$sf);
@@ -812,7 +867,7 @@ sub ensure_cached {
 
 			if (($nwidth >= 800 || $nheight >= 600 || $xres == -1) && $infobox ne 'nobox') {
 				my $info = Image::ExifTool::ImageInfo($fname);
-				make_infobox($cimg, $info, $r);
+				make_infobox($cimg, $info, $r, 1);
 			}
 
 			# Strip EXIF tags etc.
@@ -850,6 +905,13 @@ sub ensure_cached {
 			}
 		}
 	}
+	
+	# Update the SQL database if it doesn't contain the required info
+	if (!defined($dbwidth) && defined($new_dbwidth)) {
+		$r->log->info("Updating width/height for $id: $new_dbwidth x $new_dbheight");
+		update_image_info($r, $id, $new_dbwidth, $new_dbheight);
+	}
+
 	return ($cachename, 'image/jpeg');
 }
 
@@ -861,7 +923,7 @@ sub get_mimetype_from_filename {
 }
 
 sub make_infobox {
-	my ($img, $info, $r) = @_;
+	my ($img, $info, $r, $dpr) = @_;
 
 	# The infobox is of the form
 	# "Time - date - focal length, shutter time, aperture, sensitivity, exposure bias - flash",
@@ -869,10 +931,14 @@ sub make_infobox {
 	# fields"; note the comma separation. Every field has an associated "bold flag"
 	# in the second part.
 	
-	my $shutter_priority = (defined($info->{'ExposureProgram'}) &&
+	my $manual_shutter = (defined($info->{'ExposureProgram'}) &&
 		$info->{'ExposureProgram'} =~ /shutter\b.*\bpriority/i);
-	my $aperture_priority = (defined($info->{'ExposureProgram'}) &&
+	my $manual_aperture = (defined($info->{'ExposureProgram'}) &&
 		$info->{'ExposureProgram'} =~ /aperture\b.*\bpriority/i);
+	if ($info->{'ExposureProgram'} =~ /manual/i) {
+		$manual_shutter = 1;
+		$manual_aperture = 1;
+	}
 
 	my @classic_fields = ();
 	if (defined($info->{'FocalLength'}) && $info->{'FocalLength'} =~ /^(\d+)(?:\.\d+)?\s*(?:mm)?$/) {
@@ -884,24 +950,24 @@ sub make_infobox {
 	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", $shutter_priority ];
-	} elsif (defined($info->{'ExposureTime'}) && $info->{'ExposureTime'} =~ /^(\d+(?:\.\d+))$/) {
-		push @classic_fields, [ $1 . "s", $shutter_priority ];
+		push @classic_fields, [ $a/$gcd . "/" . $b/$gcd . "s", $manual_shutter ];
+	} elsif (defined($info->{'ExposureTime'}) && $info->{'ExposureTime'} =~ /^(\d+(?:\.\d+)?)$/) {
+		push @classic_fields, [ $1 . "s", $manual_shutter ];
 	}
 
 	if (defined($info->{'FNumber'}) && $info->{'FNumber'} =~ /^(\d+)\/(\d+)$/) {
 		my $f = $1/$2;
 		if ($f >= 10) {
-			push @classic_fields, [ (sprintf "f/%.0f", $f), $aperture_priority ];
+			push @classic_fields, [ (sprintf "f/%.0f", $f), $manual_aperture ];
 		} else {
-			push @classic_fields, [ (sprintf "f/%.1f", $f), $aperture_priority ];
+			push @classic_fields, [ (sprintf "f/%.1f", $f), $manual_aperture ];
 		}
 	} elsif (defined($info->{'FNumber'}) && $info->{'FNumber'} =~ /^(\d+)\.(\d+)$/) {
 		my $f = $info->{'FNumber'};
 		if ($f >= 10) {
-			push @classic_fields, [ (sprintf "f/%.0f", $f), $aperture_priority ];
+			push @classic_fields, [ (sprintf "f/%.0f", $f), $manual_aperture ];
 		} else {
-			push @classic_fields, [ (sprintf "f/%.1f", $f), $aperture_priority ];
+			push @classic_fields, [ (sprintf "f/%.1f", $f), $manual_aperture ];
 		}
 	}
 
@@ -921,7 +987,7 @@ sub make_infobox {
 
 	if (defined($info->{'ExposureBiasValue'}) && $info->{'ExposureBiasValue'} ne "0") {
 		push @classic_fields, [ $info->{'ExposureBiasValue'} . " EV", 0 ];
-	} elsif (defined($info->{'ExposureCompensation'}) && $info->{'ExposureCompensation'} != 0) {
+	} elsif (defined($info->{'ExposureCompensation'}) && $info->{'ExposureCompensation'} ne "0") {
 		push @classic_fields, [ $info->{'ExposureCompensation'} . " EV", 0 ];
 	}
 
@@ -986,7 +1052,7 @@ sub make_infobox {
 			$font = '/usr/share/fonts/truetype/msttcorefonts/Arial.ttf';
 		}
 
-		my (undef, undef, $h, undef, $w) = ($img->QueryFontMetrics(text=>$part->[0], font=>$font, pointsize=>12));
+		my (undef, undef, $h, undef, $w) = ($img->QueryFontMetrics(text=>$part->[0], font=>$font, pointsize=>12*$dpr));
 
 		$tw += $w;
 		$th = $h if ($h > $th);
@@ -995,7 +1061,7 @@ sub make_infobox {
 	return 0 if ($tw > $img->Get('columns'));
 
 	my $x = 0;
-	my $y = $img->Get('rows') - 24;
+	my $y = $img->Get('rows') - 24*$dpr;
 
 	# Hit exact DCT blocks
 	$y -= ($y % 8);
@@ -1003,13 +1069,13 @@ sub make_infobox {
 	my $points = sprintf "%u,%u %u,%u", $x, $y, ($img->Get('columns') - 1), ($img->Get('rows') - 1);
 	my $lpoints = sprintf "%u,%u %u,%u", $x, $y, ($img->Get('columns') - 1), $y;
 	$img->Draw(primitive=>'rectangle', stroke=>'white', fill=>'white', points=>$points);
-	$img->Draw(primitive=>'line', stroke=>'black', points=>$lpoints);
+	$img->Draw(primitive=>'line', stroke=>'black', strokewidth=>$dpr, points=>$lpoints);
 
 	# Start writing out the text
 	$x = ($img->Get('columns') - $tw) / 2;
 
-	my $room = ($img->Get('rows') - 1 - $y - $th);
-	$y = ($img->Get('rows') - 1) - $room/2;
+	my $room = ($img->Get('rows') - $dpr - $y - $th);
+	$y = ($img->Get('rows') - $dpr) - $room/2;
 	
 	for my $part (@parts) {
 		my $font;
@@ -1018,8 +1084,8 @@ sub make_infobox {
 		} else {
 			$font = '/usr/share/fonts/truetype/msttcorefonts/Arial.ttf';
 		}
-		$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];
+		$img->Annotate(text=>$part->[0], font=>$font, pointsize=>12*$dpr, x=>int($x), y=>int($y));
+		$x += ($img->QueryFontMetrics(text=>$part->[0], font=>$font, pointsize=>12*$dpr))[4];
 	}
 
 	return 1;
@@ -1098,8 +1164,6 @@ sub purge_cache {
 	}
 	$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.
@@ -1128,10 +1192,12 @@ sub get_all_cache_urls {
 			push @ret, "/$event/$1x$2/$filename";
 		} elsif ($fname =~ /^$id-(\d+)-(\d+)-nobox\.jpg$/) {
 			push @ret, "/$event/$1x$2/nobox/$filename";
+		} elsif ($fname =~ /^$id--1--1-box\.png$/) {
+			push @ret, "/$event/box/$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");
+			$r->log->warn("Couldn't find a purging URL for $fname");
 		}
 	}