X-Git-Url: https://git.sesse.net/?a=blobdiff_plain;f=perl%2FSesse%2Fpr0n%2FCommon.pm;h=c9511af8dbc594b21490ddd715d246554d9e5526;hb=2542338bfc131e075eca5829ba96ba5492ddc6f2;hp=c1eadfefc93d80e3566553402b91b1cd49e4417a;hpb=cbbb349dabacc46a7dfb1cd03025c710ca473179;p=pr0n

diff --git a/perl/Sesse/pr0n/Common.pm b/perl/Sesse/pr0n/Common.pm
index c1eadfe..c9511af 100644
--- a/perl/Sesse/pr0n/Common.pm
+++ b/perl/Sesse/pr0n/Common.pm
@@ -22,6 +22,7 @@ use HTML::Entities;
 use URI::Escape;
 use File::Basename;
 use Crypt::Eksblowfish::Bcrypt;
+use File::Temp;
 
 BEGIN {
 	use Exporter ();
@@ -207,20 +208,20 @@ sub get_dbh {
 
 sub get_disk_location {
 	my ($r, $id) = @_;
-        my $dir = POSIX::floor($id / 256);
+	my $dir = POSIX::floor($id / 256);
 	return $Sesse::pr0n::Config::image_base . "images/$dir/$id.jpg";
 }
 
 sub get_cache_location {
-	my ($id, $width, $height) = @_;
-        my $dir = POSIX::floor($id / 256);
+	my ($id, $width, $height, $format) = @_;
+	my $dir = POSIX::floor($id / 256);
 
-	return $Sesse::pr0n::Config::image_base . "cache/$dir/$id-$width-$height-nobox.jpg";
+	return $Sesse::pr0n::Config::image_base . "cache/$dir/$id-$width-$height-nobox.$format";
 }
 
 sub get_infobox_cache_location {
 	my ($id, $width, $height, $dpr) = @_;
-        my $dir = POSIX::floor($id / 256);
+	my $dir = POSIX::floor($id / 256);
 
 	if ($dpr == 1) {
 		return $Sesse::pr0n::Config::image_base . "cache/$dir/$id-$width-$height-box.png";
@@ -248,7 +249,7 @@ sub ensure_disk_location_exists {
 
 sub get_mipmap_location {
 	my ($r, $id, $width, $height) = @_;
-        my $dir = POSIX::floor($id / 256);
+	my $dir = POSIX::floor($id / 256);
 
 	return $Sesse::pr0n::Config::image_base . "cache/$dir/$id-mipmap-$width-$height.jpg";
 }
@@ -572,17 +573,21 @@ sub read_original_image {
 }
 
 sub ensure_cached {
-	my ($r, $filename, $id, $dbwidth, $dbheight, $xres, $yres, @otherres) = @_;
-
-	my ($new_dbwidth, $new_dbheight);
+	my ($r, $avif_ok, $filename, $id, $dbwidth, $dbheight, $xres, $yres, @otherres) = @_;
 
 	my $fname = get_disk_location($r, $id);
 	unless (defined($xres) && (!defined($dbwidth) || !defined($dbheight) || $xres < $dbwidth || $yres < $dbheight || $xres == -1)) {
 		return ($fname, undef);
 	}
 
-	my $cachename = get_cache_location($id, $xres, $yres);
-	my $err;
+	# See if we have an up-to-date AVIF to serve.
+	# (We never generate them on-the-fly, since they're so slow.)
+	my $cachename = get_cache_location($id, $xres, $yres, 'avif');
+	if ($avif_ok && -r $cachename and (-M $cachename <= -M $fname)) {
+		return ($cachename, 'image/avif');
+	}
+
+	$cachename = get_cache_location($id, $xres, $yres, 'jpg');
 	if (! -r $cachename or (-M $cachename > -M $fname)) {
 		# If we are in overload mode (aka Slashdot mode), refuse to generate
 		# new thumbnails.
@@ -591,77 +596,112 @@ sub ensure_cached {
 			error($r, 'System is in overload mode, not doing any scaling');
 		}
 
-		my $img;
-		($img, $new_dbwidth, $new_dbheight) = make_mipmap($r, $filename, $id, $dbwidth, $dbheight, $xres, $yres, @otherres);
+		make_cache($r, $filename, $id, $dbwidth, $dbheight, 'jpg', $xres, $yres, @otherres);
+	}
 
-		while (defined($xres) && defined($yres)) {
-			my ($nxres, $nyres) = (shift @otherres, shift @otherres);
-			my $cachename = get_cache_location($id, $xres, $yres);
-			
-			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 $width = $img->Get('columns');
-			my $height = $img->Get('rows');
-			my ($nwidth, $nheight) = scale_aspect($width, $height, $xres, $yres);
+	return ($cachename, 'image/jpeg');
+}
 
-			my $filter = 'Lanczos';
-			my $quality = 87;
-			my $sf = "1x1";
+sub make_cache {
+	my ($r, $filename, $id, $dbwidth, $dbheight, $format, $xres, $yres, @otherres) = @_;
 
-			if ($xres != -1) {
-				$cimg->Resize(width=>$nwidth, height=>$nheight, filter=>$filter);
-			}
+	my ($img, $new_dbwidth, $new_dbheight) = make_mipmap($r, $filename, $id, $dbwidth, $dbheight, $xres, $yres, @otherres);
 
-			# Strip EXIF tags etc.
-			$cimg->Strip();
+	# Update the SQL database if it doesn't contain the required info
+	if (!defined($dbwidth) && defined($new_dbwidth)) {
+		log_info($r, "Updating width/height for $id: $new_dbwidth x $new_dbheight");
+		update_image_info($r, $id, $new_dbwidth, $new_dbheight);
+	}
 
-			{
-				my %parms = (
-					filename => $cachename,
-					quality => $quality
-				);
-				if (($nwidth >= 640 && $nheight >= 480) ||
-				    ($nwidth >= 480 && $nheight >= 640)) {
-				    	$parms{'interlace'} = 'Plane';
-				}
-				if (defined($sf)) {
-					$parms{'sampling-factor'} = $sf;
-				}
-				$err = $cimg->write(%parms);
-			}
+	my $err;
+	while (defined($xres) && defined($yres)) {
+		my ($nxres, $nyres) = (shift @otherres, shift @otherres);
+		my $cachename = get_cache_location($id, $xres, $yres, $format);
+		
+		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 $width = $img->Get('columns');
+		my $height = $img->Get('rows');
+		my ($nwidth, $nheight) = scale_aspect($width, $height, $xres, $yres);
 
-			undef $cimg;
+		if ($format eq 'avif') {  # AVIF uses 4:2:0.
+			++$nwidth if ($nwidth % 2 == 1);
+			++$nheight if ($nheight % 2 == 1);
+		}
 
-			($xres, $yres) = ($nxres, $nyres);
+		my $filter = 'Lanczos';
+		my $quality = 87;
+		my $sf = "1x1";
 
-			log_info($r, "New cache: $nwidth x $nheight for $id.jpg");
+		if ($xres != -1) {
+			$cimg->Resize(width=>$nwidth, height=>$nheight, filter=>$filter);
 		}
-		
-		undef $img;
-		if ($err) {
-			log_warn($r, "$fname: $err");
-			$err =~ /(\d+)/;
-			if ($1 >= 400) {
-				#@$magick = ();
-				error($r, "$fname: $err");
+
+		# Strip EXIF tags etc.
+		$cimg->Strip();
+
+		if ($format eq 'jpg') {
+			my %parms = (
+				filename => $cachename,
+				quality => $quality
+			);
+			if (($nwidth >= 640 && $nheight >= 480) ||
+			    ($nwidth >= 480 && $nheight >= 640)) {
+				$parms{'interlace'} = 'Plane';
+			}
+			if (defined($sf)) {
+				$parms{'sampling-factor'} = $sf;
 			}
+			$err = $cimg->write(%parms);
+		} elsif ($format eq 'avif') {
+			# ImageMagick doesn't have AVIF support until version 7,
+			# and Debian hasn't packaged that even in unstable as of 2021.
+			# So we'll need to do it the manual way. (We don't use /tmp, for security reasons.)
+			(my $dirname = $cachename) =~ s,/[^/]*$,,;
+			my ($fh, $raw_filename) = File::Temp::tempfile('tmp.XXXXXXXX', DIR => $dirname, SUFFIX => '.yuv');
+			# Write a Y4M header, so that we get the chroma siting and color space correct.
+			printf $fh "YUV4MPEG2 W%d H%d F25:1 Ip A1:1 C420jpeg XYSCSS=420JPEG XCOLORRANGE=FULL\nFRAME\n", $nwidth, $nheight;
+			my %parms = (
+				file => $fh,
+				filename => $raw_filename,
+				'sampling-factor' => '2x2'
+			);
+			$cimg->write(%parms);
+			close($fh);
+			my $ivf_filename;
+			($fh, $ivf_filename) = File::Temp::tempfile('tmp.XXXXXXXX', DIR => $dirname, SUFFIX => '.ivf');
+			close($fh);
+			system('aomenc', '--quiet', '--cpu-used=0', '--bit-depth=10', '--end-usage=q', '--cq-level=10', '--target-bitrate=0', '--good', '--aq-mode=1', '--matrix-coefficients=bt601', '-o', $ivf_filename, $raw_filename);
+			unlink($raw_filename);
+			system('MP4Box', '-quiet', '-add-image', "$ivf_filename:primary", '-ab', 'avif', '-ab', 'miaf', '-new', $cachename);
+			unlink($ivf_filename);
+		} else {
+			die "Unknown format $format";
 		}
+
+		undef $cimg;
+
+		($xres, $yres) = ($nxres, $nyres);
+
+		log_info($r, "New cache: $nwidth x $nheight ($format) for $id");
 	}
 	
-	# Update the SQL database if it doesn't contain the required info
-	if (!defined($dbwidth) && defined($new_dbwidth)) {
-		log_info($r, "Updating width/height for $id: $new_dbwidth x $new_dbheight");
-		update_image_info($r, $id, $new_dbwidth, $new_dbheight);
+	undef $img;
+	if ($err) {
+		log_warn($r, "$filename: $err");
+		$err =~ /(\d+)/;
+		if ($1 >= 400) {
+			#@$magick = ();
+			error($r, "$filename: $err");
+		}
 	}
-
-	return ($cachename, 'image/jpeg');
 }
 
 sub ensure_infobox_cached {
@@ -1032,7 +1072,7 @@ sub get_server_name {
 
 sub log_info {
 	my ($r, $msg) = @_;
-	if (defined($r->logger)) {
+	if (defined($r->{'logger'})) {
 		$r->logger->({ level => 'info', message => $msg });
 	} else {
 		print STDERR "[INFO] $msg\n";
@@ -1041,7 +1081,7 @@ sub log_info {
 
 sub log_warn {
 	my ($r, $msg) = @_;
-	if (defined($r->logger)) {
+	if (defined($r->{'logger'})) {
 		$r->logger->({ level => 'warn', message => $msg });
 	} else {
 		print STDERR "[WARN] $msg\n";
@@ -1050,7 +1090,7 @@ sub log_warn {
 
 sub log_error {
 	my ($r, $msg) = @_;
-	if (defined($r->logger)) {
+	if (defined($r->{'logger'})) {
 		$r->logger->({ level => 'error', message => $msg });
 	} else {
 		print STDERR "[ERROR] $msg\n";