use DBD::Pg;
use Image::Magick;
use POSIX;
-use Digest::MD5;
use Digest::SHA;
use Digest::HMAC_SHA1;
use MIME::Base64;
use HTML::Entities;
use URI::Escape;
use File::Basename;
+use Crypt::Eksblowfish::Bcrypt;
BEGIN {
use Exporter ();
require Sesse::pr0n::Config_local;
};
- $VERSION = "v2.80";
+ $VERSION = "v2.81";
@ISA = qw(Exporter);
@EXPORT = qw(&error &dberror);
%EXPORT_TAGS = qw();
$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 {
}
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') {
} 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";
+ }
}
}
if ($auth =~ /^Basic ([a-zA-Z0-9+\/]+=*)$/) {
return check_basic_auth($r, $1);
}
- if ($auth =~ /^Digest (.*)$/) {
- return check_digest_auth($r, $1);
- }
output_401($r);
return undef;
}
$r->status(401);
$r->headers_out->{'www-authenticate'} = 'Basic realm="pr0n.sesse.net"';
- # 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_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_SHA->hmac_sha1_hex($ts . "", $Sesse::pr0n::Config::db_password);
- my $stale_nonce_text = "";
- $stale_nonce_text = ", stale=\"true\"" if ($options{'StaleNonce'} // 0);
-
- $r->headers_out->{'www-authenticate'} =
- "Digest realm=\"pr0n.sesse.net\", " .
- "nonce=\"$nonce\", " .
- "opaque=\"$ts\", " .
- "qop=\"auth\"" . $stale_nonce_text; # FIXME: support auth-int
- }
-
$r->print("Need authorization\n");
}
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 FROM users WHERE username=? AND vhost=?',
undef, $user, $r->get_server_name);
- if (!defined($ref) || $ref->{'sha1password'} ne Digest::SHA::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);
}
$r->log->info("Authentication succeeded for $user/$takenby");
- # Make sure we can use Digest authentication in the future with this password.
- my $ha1 = Digest::MD5::md5_hex($user . ':pr0n.sesse.net:' . $pass);
- if (!defined($ref->{'digest_ha1_hex'}) || $ref->{'digest_ha1_hex'} ne $ha1) {
- $dbh->do('UPDATE users SET digest_ha1_hex=? WHERE username=? AND vhost=?',
- undef, $ha1, $user, $r->get_server_name)
+ # 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 Digest auth hash for for $user");
+ $r->log->info("Updated bcrypt hash for $user");
}
return ($user, $takenby);
}
-sub check_digest_auth {
- my ($r, $auth) = @_;
-
- # We're a bit more liberal than RFC2069 in the parsing here, allowing
- # quoted strings everywhere.
- my %auth = ();
- while ($auth =~ s/^ ([a-zA-Z]+) # key
- =
- (
- [^",]* # either something that doesn't contain comma or quotes
- |
- " ( [^"\\] | \\ . ) * " # or a full quoted string
- )
- (?: (?: , \s* ) + | $ ) # delimiter(s), or end of string
- //x) {
- my ($key, $value) = ($1, $2);
- if ($value =~ /^"(.*)"$/) {
- $value = $1;
- $value =~ s/\\(.)/$1/g;
+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): $!";
}
- $auth{$key} = $value;
- }
- unless (exists($auth{'username'}) &&
- exists($auth{'uri'}) &&
- exists($auth{'nonce'}) &&
- exists($auth{'opaque'}) &&
- exists($auth{'response'})) {
- output_401($r);
- return undef;
- }
- if ($r->uri ne $auth{'uri'}) {
- output_401($r);
- return undef;
- }
-
- # Verify that the opaque data does indeed look like a timestamp, and that the nonce
- # is indeed a signed version of it.
- if ($auth{'opaque'} !~ /^\d+$/) {
- output_401($r);
- return undef;
+ $bytes .= $tmp;
+ $num_left -= length($bytes);
}
- my $compare_nonce = Digest::HMAC_SHA1->hmac_sha1_hex($auth{'opaque'}, $Sesse::pr0n::Config::db_password);
- if ($auth{'nonce'} ne $compare_nonce) {
- output_401($r);
- return undef;
- }
-
- # Now look up the user's HA1 from the database, and calculate HA2.
- my ($user, $takenby) = extract_takenby($auth{'username'});
- my $ref = $dbh->selectrow_hashref('SELECT digest_ha1_hex FROM users WHERE username=? AND vhost=?',
- undef, $user, $r->get_server_name);
- if (!defined($ref)) {
- output_401($r);
- return undef;
- }
- if (!defined($ref->{'digest_ha1_hex'}) || $ref->{'digest_ha1_hex'} !~ /^[0-9a-f]{32}$/) {
- # A user that exists but has empty HA1 is a user that's not
- # ready for digest auth, so we hack it and resend 401,
- # only this time without digest auth.
- output_401($r, DigestAuth => 0);
- return undef;
- }
- my $ha1 = $ref->{'digest_ha1_hex'};
- my $ha2 = Digest::MD5::md5_hex($r->method . ':' . $auth{'uri'});
- my $response;
- if (exists($auth{'qop'}) && $auth{'qop'} eq 'auth') {
- unless (exists($auth{'nc'}) && exists($auth{'cnonce'})) {
- output_401($r);
- return undef;
- }
-
- $response = $ha1;
- $response .= ':' . $auth{'nonce'};
- $response .= ':' . $auth{'nc'};
- $response .= ':' . $auth{'cnonce'};
- $response .= ':' . $auth{'qop'};
- $response .= ':' . $ha2;
- } else {
- $response = $ha1;
- $response .= ':' . $auth{'nonce'};
- $response .= ':' . $ha2;
- }
- if ($auth{'response'} ne Digest::MD5::md5_hex($response)) {
- output_401($r);
- return undef;
- }
-
- # OK, everything is good, and there's only one thing we need to check: That the nonce
- # isn't too old. If it is, but everything else is ok, we tell the browser that and it
- # will re-encrypt with the new nonce.
- my $timediff = time - $auth{'opaque'};
- if ($timediff < 0 || $timediff > 300) {
- output_401($r, StaleNonce => 1);
- return undef;
- }
-
- return ($user, $takenby);
+ close $randfh;
+ return $bytes;
}
sub extract_takenby {
}
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 $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
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
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)) {
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.
}
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",
$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);
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);
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;
} 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;
projects / pr0n / blobdiff