X-Git-Url: https://git.sesse.net/?p=pr0n;a=blobdiff_plain;f=perl%2FSesse%2Fpr0n%2FCommon.pm;h=d325907b71395e57298499b8718c9f5f8f480a64;hp=57d0a6ba26b66514ab9d1b3f9abc5d675efa8d40;hb=97d5bb1e417a37cf3e0cec8bf75bed3a971f913b;hpb=fd1e8cc4d43ed344438cb93e203ca146fe243487

diff --git a/perl/Sesse/pr0n/Common.pm b/perl/Sesse/pr0n/Common.pm
index 57d0a6b..d325907 100644
--- a/perl/Sesse/pr0n/Common.pm
+++ b/perl/Sesse/pr0n/Common.pm
@@ -18,7 +18,9 @@ use DBI;
 use DBD::Pg;
 use Image::Magick;
 use POSIX;
+use Digest::MD5;
 use Digest::SHA1;
+use Digest::HMAC_SHA1;
 use MIME::Base64;
 use MIME::Types;
 use LWP::Simple;
@@ -37,7 +39,7 @@ BEGIN {
 		require Sesse::pr0n::Config_local;
 	};
 
-	$VERSION     = "v2.70";
+	$VERSION     = "v2.71";
 	@ISA         = qw(Exporter);
 	@EXPORT      = qw(&error &dberror);
 	%EXPORT_TAGS = qw();
@@ -312,19 +314,186 @@ 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+/]+=*)$#) {
+	if (!defined($auth)) {
+		output_401($r);
+		return undef;
+	} 
+	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;
+}
+
+sub output_401 {
+	my ($r, %options) = @_;
+	$r->content_type('text/plain; charset=utf-8');
+	$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_SHA1 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 $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");
+}
+
+sub check_basic_auth {
+	my ($r, $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=?',
+		undef, $user, $r->get_server_name);
+	if (!defined($ref) || $ref->{'sha1password'} ne Digest::SHA1::sha1_base64($pass)) {
 		$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");
+		$r->log->warn("Authentication failed for $user/$takenby");
+		output_401($r);
+		return undef;
+	}
+	$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)
+			or die "Couldn't update: " . $dbh->errstr;
+		$r->log->info("Updated Digest auth hash for 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;
+		}
+		$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;
 	}
 	
-	#return qw(sesse Sesse);
+	# 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;
+	}
+	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);
+}
+
+sub extract_takenby {
+	my ($user) = shift;
 
-	my ($user, $pass) = split /:/, MIME::Base64::decode_base64($1);
 	# WinXP is stupid :-)
 	if ($user =~ /^.*\\(.*)$/) {
 		$user = $1;
@@ -337,22 +506,6 @@ sub check_access {
 	} else {
 		($takenby = $user) =~ s/^([a-zA-Z])/uc($1)/e;
 	}
-	
-	my $oldpass = $pass;
-	$pass = Digest::SHA1::sha1_base64($pass);
-	my $ref = $dbh->selectrow_hashref('SELECT count(*) AS auth FROM users WHERE username=? AND sha1password=? AND vhost=?',
-		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");
-		return undef;
-	}
-
-	$r->log->info("Authentication succeeded for $user/$takenby");
 
 	return ($user, $takenby);
 }
@@ -530,7 +683,7 @@ 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;
@@ -553,7 +706,7 @@ sub ensure_cached {
 
 	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);
 		}
 	}
@@ -643,16 +796,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);
@@ -733,7 +879,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+(?:\.\d+))$/) {
+	} elsif (defined($info->{'ExposureTime'}) && $info->{'ExposureTime'} =~ /^(\d+(?:\.\d+)?)$/) {
 		push @classic_fields, [ $1 . "s", $shutter_priority ];
 	}
 
@@ -769,7 +915,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 ];
 	}
 
@@ -976,10 +1122,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");
 		}
 	}