X-Git-Url: https://git.sesse.net/?a=blobdiff_plain;f=perl%2FSesse%2Fpr0n%2FCommon.pm;h=101cee6283603405dfcc5830dd9e277e837a0613;hb=78229c85e0965be553209569da657ffb0a35366e;hp=ab90961dc567a127236c5eae822c9e491c2d85c2;hpb=c53dd5ce79ebfdcf01c3847149611ebafcebdd69;p=pr0n diff --git a/perl/Sesse/pr0n/Common.pm b/perl/Sesse/pr0n/Common.pm index ab90961..101cee6 100644 --- a/perl/Sesse/pr0n/Common.pm +++ b/perl/Sesse/pr0n/Common.pm @@ -13,8 +13,6 @@ use DBD::Pg; use Image::Magick; use IO::String; use POSIX; -use Digest::SHA; -use Digest::HMAC_SHA1; use MIME::Base64; use MIME::Types; use LWP::Simple; @@ -24,6 +22,7 @@ use HTML::Entities; use URI::Escape; use File::Basename; use Crypt::Eksblowfish::Bcrypt; +use File::Temp; BEGIN { use Exporter (); @@ -34,7 +33,7 @@ BEGIN { require Sesse::pr0n::Config_local; }; - $VERSION = "v3.00-pre"; + $VERSION = "v3.20"; @ISA = qw(Exporter); @EXPORT = qw(&error &dberror); %EXPORT_TAGS = qw(); @@ -130,7 +129,8 @@ sub get_query_string { my $first = 1; my $str = ""; - while (my ($key, $value) = each %$param) { + for my $key (sort keys %$param) { + my $value = $param->{$key}; next unless defined($value); next if (defined($defparam->{$key}) && $value == $defparam->{$key}); @@ -208,23 +208,15 @@ 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 ($r, $id, $width, $height, $infobox, $dpr) = @_; - my $dir = POSIX::floor($id / 256); + my ($id, $width, $height, $format) = @_; + my $dir = POSIX::floor($id / 256); - if ($infobox) { - if ($dpr == 1) { - return $Sesse::pr0n::Config::image_base . "cache/$dir/$id-$width-$height-box.png"; - } else { - return $Sesse::pr0n::Config::image_base . "cache/$dir/$id-$width-$height-box\@$dpr.png"; - } - } else { - 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 ensure_disk_location_exists { @@ -234,19 +226,21 @@ sub ensure_disk_location_exists { my $img_dir = $Sesse::pr0n::Config::image_base . "/images/$dir/"; if (! -d $img_dir) { log_info($r, "Need to create new image directory $img_dir"); - mkdir($img_dir) or die "Couldn't create new image directory $img_dir"; + mkdir($img_dir); # Ignore errors, there could be a race. + -d $img_dir or die "Couldn't create new image directory $img_dir"; } my $cache_dir = $Sesse::pr0n::Config::image_base . "/cache/$dir/"; if (! -d $cache_dir) { log_info($r, "Need to create new cache directory $cache_dir"); - mkdir($cache_dir) or die "Couldn't create new image directory $cache_dir"; + mkdir($cache_dir); # Ignore errors, there could be a race. + -d $cache_dir or die "Couldn't create new cache directory $cache_dir"; } } 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"; } @@ -342,35 +336,16 @@ 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,cryptpassword FROM users WHERE username=? AND vhost=?', + my $ref = $dbh->selectrow_hashref('SELECT cryptpassword FROM users WHERE username=? AND vhost=?', undef, $user, Sesse::pr0n::Common::get_server_name($r)); - 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)) { + my $bcrypt_matches = 0; + if (!defined($ref) || Crypt::Eksblowfish::Bcrypt::bcrypt($pass, $ref->{'cryptpassword'}) ne $ref->{'cryptpassword'}) { $r->content_type('text/plain; charset=utf-8'); log_warn($r, "Authentication failed for $user/$takenby"); return undef; } log_info($r, "Authentication succeeded for $user/$takenby"); - # 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, Sesse::pr0n::Common::get_server_name($r)) - or die "Couldn't update: " . $dbh->errstr; - log_info($r, "Updated bcrypt hash for $user"); - } - return ($user, $takenby); } @@ -544,17 +519,9 @@ sub read_original_image { } 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 ($filename =~ /\.(nef|cr2)$/i) { - # this would suffice if ImageMagick gets to fix their handling - # $physical_fname = "NEF:$physical_fname"; - - open DCRAW, "-|", "dcraw", "-w", "-c", $physical_fname - or error("dcraw: $!"); - $err = $magick->Read(file => \*DCRAW); - close(DCRAW); + $physical_fname = "NEF:$physical_fname"; + $err = $magick->Read($physical_fname); } else { # We always want YCbCr JPEGs. Setting this explicitly here instead of using # RGB is slightly faster (no colorspace conversion needed) and works equally @@ -589,19 +556,26 @@ sub read_original_image { } sub ensure_cached { - my ($r, $filename, $id, $dbwidth, $dbheight, $infobox, $dpr, $xres, $yres, @otherres) = @_; - - my ($new_dbwidth, $new_dbheight); + my ($r, $avif_ok, $jxl_ok, $filename, $id, $dbwidth, $dbheight, $xres, $yres, @otherres) = @_; my $fname = get_disk_location($r, $id); - if (!$infobox) { - unless (defined($xres) && (!defined($dbwidth) || !defined($dbheight) || $xres < $dbwidth || $yres < $dbheight || $xres == -1)) { - return ($fname, undef); - } + 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, $dpr); - my $err; + # See if we have an up-to-date JPEG-XL or AVIF to serve. + # (We never generate them on-the-fly, since they're so slow.) + my $cachename = get_cache_location($id, $xres, $yres, 'jxl'); + if ($jxl_ok && -r $cachename and (-M $cachename <= -M $fname)) { + return ($cachename, 'image/jxl'); + } + + $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. @@ -610,128 +584,119 @@ sub ensure_cached { error($r, 'System is in overload mode, not doing any scaling'); } - # If we're being asked for the box, make a new image with it. - # 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) { - 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); - $new_dbwidth = $width = $img->Get('columns'); - $new_dbheight = $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 * $dpr; - $img->Set(size=>($width . "x" . $height)); - $img->Read('xc:white'); - - my $info = Image::ExifTool::ImageInfo($fname); - if (make_infobox($img, $info, $r, $dpr)) { - $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:'); + make_cache($r, $filename, $id, $dbwidth, $dbheight, 'jpg', $xres, $yres, @otherres); + } - $width = 1; - $height = 1; - } - - $err = $img->write(filename => $cachename, quality => 90, depth => 8); - log_info($r, "New infobox cache: $width x $height for $id.jpg"); - - return ($cachename, 'image/png'); - } + return ($cachename, 'image/jpeg'); +} - my $img; - ($img, $new_dbwidth, $new_dbheight) = make_mipmap($r, $filename, $id, $dbwidth, $dbheight, $xres, $yres, @otherres); +sub make_cache { + my ($r, $filename, $id, $dbwidth, $dbheight, $format, $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, $dpr); - - 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 ($img, $new_dbwidth, $new_dbheight) = make_mipmap($r, $filename, $id, $dbwidth, $dbheight, $xres, $yres, @otherres); + + # 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 $err; + while (defined($xres) && defined($yres)) { + my ($nxres, $nyres) = (shift @otherres, shift @otherres); + my $cachename = get_cache_location($id, $xres, $yres, $format); - my $width = $img->Get('columns'); - my $height = $img->Get('rows'); - my ($nwidth, $nheight) = scale_aspect($width, $height, $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); - my $filter = 'Lanczos'; - my $quality = 87; - my $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); - } + if ($xres != -1) { + $cimg->Resize(width=>$nwidth, height=>$nheight, filter=>$filter); + } - # Strip EXIF tags etc. - $cimg->Strip(); + # Strip EXIF tags etc. + $cimg->Strip(); - { - 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); + 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 => '.ycbcr'); + # Write a Y4M header, so that we get the chroma range correct. + printf $fh "YUV4MPEG2 W%d H%d F25:1 Ip A1:1 C444 XYSCSS=444 XCOLORRANGE=FULL\nFRAME\n", $nwidth, $nheight; + my %parms = ( + file => $fh, + filename => $raw_filename, + interlace => 'Plane' + ); + $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=13', '--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); + } elsif ($format eq 'jxl') { + # Similar, for JPEG-XL. + (my $dirname = $cachename) =~ s,/[^/]*$,,; + my ($fh, $raw_filename) = File::Temp::tempfile('tmp.XXXXXXXX', DIR => $dirname, SUFFIX => '.ppm'); + my %parms = ( + file => $fh, + filename => $raw_filename + ); + $cimg->write(%parms); + close($fh); + system('cjxl', '-p', $raw_filename, $cachename); + unlink($raw_filename); + } else { + die "Unknown format $format"; + } - undef $cimg; + undef $cimg; - ($xres, $yres) = ($nxres, $nyres); + ($xres, $yres) = ($nxres, $nyres); - log_info($r, "New cache: $nwidth x $nheight for $id.jpg"); - } - - undef $img; - if ($err) { - log_warn($r, "$fname: $err"); - $err =~ /(\d+)/; - if ($1 >= 400) { - #@$magick = (); - error($r, "$fname: $err"); - } - } + 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 get_mimetype_from_filename { @@ -741,8 +706,8 @@ sub get_mimetype_from_filename { return $type; } -sub make_infobox { - my ($img, $info, $r, $dpr) = @_; +sub make_infobox_parts { + my ($info) = @_; # The infobox is of the form # "Time - date - focal length, shutter time, aperture, sensitivity, exposure bias - flash", @@ -754,7 +719,7 @@ sub make_infobox { $info->{'ExposureProgram'} =~ /shutter\b.*\bpriority/i); my $manual_aperture = (defined($info->{'ExposureProgram'}) && $info->{'ExposureProgram'} =~ /aperture\b.*\bpriority/i); - if ($info->{'ExposureProgram'} =~ /manual/i) { + if (defined($info->{'ExposureProgram'}) && $info->{'ExposureProgram'} =~ /manual/i) { $manual_shutter = 1; $manual_aperture = 1; } @@ -824,13 +789,13 @@ sub make_infobox { $model =~ s/^\s+//; $model =~ s/\s+$//; - push @parts, [ ' - ', 0 ] if (scalar @parts > 0); + push @parts, [ "\x{00A0}\x{2013}\x{00A0}", 0 ] if (scalar @parts > 0); push @parts, [ $model, 0 ]; } # classic fields if (scalar @classic_fields > 0) { - push @parts, [ ' - ', 0 ] if (scalar @parts > 0); + push @parts, [ "\x{00A0}\x{2013}\x{00A0}", 0 ] if (scalar @parts > 0); my $first_elem = 1; for my $field (@classic_fields) { @@ -845,69 +810,19 @@ sub make_infobox { $info->{'Flash'} =~ /no flash/i || $info->{'Flash'} =~ /not fired/i || $info->{'Flash'} =~ /Off/) { - push @parts, [ ' - ', 0 ] if (scalar @parts > 0); + push @parts, [ "\x{00A0}\x{2013}\x{00A0}", 0 ] if (scalar @parts > 0); push @parts, [ "No flash", 0 ]; } elsif ($info->{'Flash'} =~ /fired/i || $info->{'Flash'} =~ /On/) { - push @parts, [ ' - ', 0 ] if (scalar @parts > 0); + push @parts, [ "\x{00A0}\x{2013}\x{00A0}", 0 ] if (scalar @parts > 0); push @parts, [ "Flash", 0 ]; } else { - push @parts, [ ' - ', 0 ] if (scalar @parts > 0); + push @parts, [ "\x{00A0}\x{2013}\x{00A0}", 0 ] if (scalar @parts > 0); push @parts, [ $info->{'Flash'}, 0 ]; } } - return 0 if (scalar @parts == 0); - - # Find the required width - my $th = 0; - my $tw = 0; - - for my $part (@parts) { - my $font; - if ($part->[1]) { - $font = '/usr/share/fonts/truetype/msttcorefonts/Arial_Bold.ttf'; - } else { - $font = '/usr/share/fonts/truetype/msttcorefonts/Arial.ttf'; - } - - my (undef, undef, $h, undef, $w) = ($img->QueryFontMetrics(text=>$part->[0], font=>$font, pointsize=>12*$dpr)); - - $tw += $w; - $th = $h if ($h > $th); - } - - return 0 if ($tw > $img->Get('columns')); - - my $x = 0; - my $y = $img->Get('rows') - 24*$dpr; - - # Hit exact DCT blocks - $y -= ($y % 8); - - 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', strokewidth=>$dpr, points=>$lpoints); - - # Start writing out the text - $x = ($img->Get('columns') - $tw) / 2; - - my $room = ($img->Get('rows') - $dpr - $y - $th); - $y = ($img->Get('rows') - $dpr) - $room/2; - - for my $part (@parts) { - my $font; - if ($part->[1]) { - $font = '/usr/share/fonts/truetype/msttcorefonts/Arial_Bold.ttf'; - } else { - $font = '/usr/share/fonts/truetype/msttcorefonts/Arial.ttf'; - } - $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; + return @parts; } sub gcd { @@ -1011,10 +926,6 @@ 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 { log_warn($r, "Couldn't find a purging URL for $fname"); } @@ -1026,8 +937,8 @@ sub get_all_cache_urls { sub set_last_modified { my ($res, $mtime) = @_; - my $str = POSIX::strftime("%a, %d %b %Y %H:%M:%S %Z", localtime($mtime)); - $res->headers({ 'Last-Modified' => $str }); + my $str = POSIX::strftime("%a, %d %b %Y %H:%M:%S GMT", gmtime($mtime)); + $res->header('Last-Modified' => $str); } sub get_server_name { @@ -1039,7 +950,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"; @@ -1048,7 +959,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"; @@ -1057,7 +968,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";