X-Git-Url: https://git.sesse.net/?p=pr0n;a=blobdiff_plain;f=perl%2FSesse%2Fpr0n%2FCommon.pm;h=60e9469d57e7ece412f228cd49f7fc61b6df3f0b;hp=00fa9e9b0c42213676fc70707955ba8a9a696988;hb=a87e90cdd5ed56bc6bfa460a9b56f587a65bebd3;hpb=4c67de43660ea5ee7077ab8c2c6b787471901a71 diff --git a/perl/Sesse/pr0n/Common.pm b/perl/Sesse/pr0n/Common.pm index 00fa9e9..60e9469 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; @@ -26,6 +28,7 @@ use LWP::Simple; use Image::ExifTool; use HTML::Entities; use URI::Escape; +use File::Basename; BEGIN { use Exporter (); @@ -311,31 +314,61 @@ 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+/]+=*)$#) { - $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"); + if (!defined($auth)) { + output_401($r); return undef; + } + $r->log->warn("Auth: $auth"); + if ($auth =~ /^Basic ([a-zA-Z0-9+\/]+=*)$/) { + return check_basic_auth($r, $1); + } + if ($auth =~ /^Digest (.*)$/) { + return check_digest_auth($r, $1); } - - #return qw(sesse Sesse); + output_401($r); + return undef; +} - my ($user, $pass) = split /:/, MIME::Base64::decode_base64($1); - # WinXP is stupid :-) - if ($user =~ /^.*\\(.*)$/) { - $user = $1; +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"'; + + if ($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 } - my $takenby; - if ($user =~ /^([a-zA-Z0-9^_-]+)\@([a-zA-Z0-9^_-]+)$/) { - $user = $1; - $takenby = $2; - } else { - ($takenby = $user) =~ s/^([a-zA-Z])/uc($1)/e; - } + $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 $oldpass = $pass; $pass = Digest::SHA1::sha1_base64($pass); @@ -343,11 +376,8 @@ sub check_access { 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"); + output_401($r); return undef; } @@ -355,6 +385,124 @@ sub check_access { 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; + } + + # 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; + + # WinXP is stupid :-) + if ($user =~ /^.*\\(.*)$/) { + $user = $1; + } + + my $takenby; + if ($user =~ /^([a-zA-Z0-9^_-]+)\@([a-zA-Z0-9^_-]+)$/) { + $user = $1; + $takenby = $2; + } else { + ($takenby = $user) =~ s/^([a-zA-Z])/uc($1)/e; + } + + return ($user, $takenby); +} sub stat_image { my ($r, $event, $filename) = (@_); @@ -879,7 +1027,7 @@ sub gcd { } sub add_new_event { - my ($dbh, $id, $date, $desc, $vhost) = @_; + my ($r, $dbh, $id, $date, $desc) = @_; my @errors = (); if (!defined($id) || $id =~ /^\s*$/ || $id !~ /^([a-zA-Z0-9-]+)$/) { @@ -896,12 +1044,14 @@ sub add_new_event { return @errors; } + my $vhost = $r->get_server_name; $dbh->do("INSERT INTO events (event,date,name,vhost) VALUES (?,?,?,?)", undef, $id, $date, $desc, $vhost) or return ("Kunne ikke sette inn ny hendelse" . $dbh->errstr); $dbh->do("INSERT INTO last_picture_cache (vhost,event,last_picture) VALUES (?,?,NULL)", undef, $vhost, $id) or return ("Kunne ikke sette inn ny cache-rad" . $dbh->errstr); + purge_cache($r, "/"); return (); } @@ -920,6 +1070,69 @@ sub guess_charset { return $decoded; } +# Depending on your front-end cache, you might want to get creative somehow here. +# This example assumes you have a front-end cache and it can translate an X-Pr0n-Purge +# regex tacked onto a request into something useful. The elements given in +# should not be regexes, though, as e.g. Squid will not be able to handle that. +sub purge_cache { + my ($r, @elements) = @_; + return if (scalar @elements == 0); + + my @pe = (); + for my $elem (@elements) { + $r->log->info("Purging $elem"); + (my $e = $elem) =~ s/[.+*|()]/\\$&/g; + push @pe, $e; + } + + my $regex = "^"; + if (scalar @pe == 1) { + $regex .= $pe[0]; + } else { + $regex .= "(" . join('|', @pe) . ")"; + } + $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. +sub get_all_cache_urls { + my ($r, $dbh, $id) = @_; + my $dir = POSIX::floor($id / 256); + my @ret = (); + + my $q = $dbh->prepare('SELECT event, filename FROM images WHERE id=?') + or die "Couldn't prepare: " . $dbh->errstr; + $q->execute($id) + or die "Couldn't find event and filename: " . $dbh->errstr; + my $ref = $q->fetchrow_hashref; + my $event = $ref->{'event'}; + my $filename = $ref->{'filename'}; + $q->finish; + + my $base = get_base($r) . "cache/$dir"; + for my $file (<$base/$id-*>) { + my $fname = File::Basename::basename($file); + if ($fname =~ /^$id-mipmap-.*\.jpg$/) { + # Mipmaps don't have an URL, ignore + } elsif ($fname =~ /^$id--1--1\.jpg$/) { + push @ret, "/$event/$filename"; + } elsif ($fname =~ /^$id-(\d+)-(\d+)\.jpg$/) { + push @ret, "/$event/$1x$2/$filename"; + } elsif ($fname =~ /^$id-(\d+)-(\d+)-nobox\.jpg$/) { + push @ret, "/$event/$1x$2/nobox/$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"); + } + } + + return @ret; +} + 1;