## PerlAuthenHandler Stonehenge::RestrictToList

package Stonehenge::RestrictToList;
use strict;

use vars qw($VERSION);
$VERSION = (qw$Revision$ )[-1];

## config

my $DIR = "/home/merlyn/Web/RestrictToList";
my $FAIL = "/cgi/restricttolist";

## end config

use Apache::Constants qw(:common);
use Apache::URI;
use Apache::File;

sub handler {
  use Stonehenge::Reload; goto &handler if Stonehenge::Reload->reload_me;

  my $r = shift;
  my $log = $r->log;

  my $sent_pw = do {
    my ($result,$pw) = $r->get_basic_auth_pw;
    return $result unless $result == OK;
    $pw;
  };
  my $sent_user = $r->connection->user;
  my $auth_name = $r->auth_name;

  my $db_handle = do {
    my $name = $auth_name;
    $name =~ tr/A-Za-z0-9//cd;
    $name = "$DIR/$name";
    Apache::File->new("<$name") or do {
      $r->note_basic_auth_failure;
      $r->log_reason("no database for $auth_name ($name)");
      return SERVER_ERROR;
    };
  };

  {
    my $error_uri = Apache::URI->parse($r, $FAIL);
    $error_uri->query(join "", "realm=",
                      map "%$_", unpack("H*",$auth_name) =~ /(..)/g);
    $r->custom_response(AUTH_REQUIRED, $error_uri->unparse);
  }

  while (<$db_handle>) {
    my ($email, $keys, $user, $pw) = split;
    next unless $user and $user eq $sent_user;
    if ($pw eq crypt($sent_pw,$pw)) {
      $r->push_handlers
        (PerlAuthzHandler => sub {
           my %keys = map { $_, 1 } split /\W+/, $keys;
         ENTRY:
           for my $entry (@{$r->requires}) {
             ## entries are or'ed, locks are and'ed
             my $op = $entry->{requirement};
             return OK if $op eq 'valid-user';
             my @locks = split /\W+/, $op;
             for my $lock (@locks) {
               next ENTRY unless $keys{$lock};
             }
             return OK;         # the someone we know is OK here
           }
           $r->note_basic_auth_failure;
           $r->log_reason("user $user not keyed for ", $r->uri);
           return AUTH_REQUIRED;
         });
      return OK;                # they are somebody we know
    }
    $r->note_basic_auth_failure;
    $r->log_reason("password $sent_pw not valid for $user");
    return AUTH_REQUIRED;
  }

  $r->note_basic_auth_failure;
  $r->log_reason("username $sent_user not recognized");
  return AUTH_REQUIRED;
}

1;