File Coverage

blib/lib/Apache2/AuthenDBMCache.pm

Criterion	Covered	Total	%
statement	1	3	33.3
branch			n/a
condition			n/a
subroutine	1	1	100.0
pod			n/a
total	2	4	50.0

# $Id: AuthenDBMCache.pm,v 1.17 2006/03/02 21:13:21 reggers Exp $
#
# Author          : Reg Quinton
# Created On      : 23-Sep-2002
# Derivation      : from AuthenCache by Jason Bodnar, Christian Gilmore
# Status          : Functional
#
# PURPOSE
#    User Authentication Cache implemented in a DBM database.

# Package name

package Apache2::AuthenDBMCache;

# Required libraries

use mod_perl2 ;
use Apache2::Access ;
use Apache2::Log ;
use Apache2::RequestRec ;
use Apache2::RequestUtil ;
use Apache2::Const -compile => qw(HTTP_UNAUTHORIZED HTTP_INTERNAL_SERVER_ERROR DECLINED HTTP_FORBIDDEN OK) ;
use APR::Table ;
use Carp;
use strict;
use warnings FATAL => 'all';

# Global variables

$Apache2::AuthenDBMCache::VERSION = '0.01';

# local subroutines and data not exported to anyone

my($cache)= "/var/cache/authen-web/cache";

# key index to value -- an expiration date.

sub GetCache {
    my (%DBM);    my($key)=@_;

    croak "No access to $cache"
	unless dbmopen(%DBM,$cache,0600);

    my ($tmp)=$DBM{$key}; dbmclose(%DBM);

    return ($tmp);
}

sub SetCache {
    my (%DBM);    my ($key,$val)=@_;

    croak "No access to $cache"
	unless dbmopen(%DBM,$cache,0600);

    $DBM{$key}=$val;    dbmclose(%DBM);
}

sub ExpireCache {
    my ($file) = @_;
    $cache=$file if $file;

    my (%DBM,$key,$now);

    croak "No access to $cache"
	unless dbmopen(%DBM,$cache,0600);

    $now=time();

    foreach $key (keys %DBM) {
	delete $DBM{$key} if $DBM{$key} < $now;
    }

    dbmclose(%DBM);

}

# squish userid, password, config and realm into a hash

sub Digest {
    use Digest::MD5;

    my ($string)=Digest::MD5->md5_hex(@_);
    $string=~ s/[^0-9a-zA-Z]//g;
    return($string);
}

# handler: hook into Apache2/mod_perl2 API

sub handler {
  my $r = shift;
  my $tmp;

  # Get response and password

  my($status, $passwd) = $r->get_basic_auth_pw;
  return Apache2::Const::OK unless $r->is_initial_req;
  return $status unless ($status == Apache2::Const::OK); # e.g. HTTP_UNAUTHORIZED
  # Get configuration... are we debugging?

  my $debug = (lc($r->dir_config('AuthenDBMCache_Debug')) eq 'on');
  $cache=$tmp if ($tmp = $r->dir_config('AuthenDBMCache_file'));

  # Get username and Realm

  my $realm = lc($r->auth_name);
  my $user  = lc($r->user);
  return Apache2::Const::DECLINED  unless ($user);

  # Get all parameters -- current config (to limit cache poison).

  my $config=$r->dir_config(); $config=join(":",%$config);

  # construct a unique key for userid/realm/config/password

  my $key   = Digest("$user $realm $config $passwd");

  $r->log->debug("handler: user=$user") if $debug;

  # if there is an expiration date for that key

  if (my $exp = GetCache("$key")) {
      if ($exp < time()) {
	  $r->log->debug("handler: user cache stale") if $debug;
	  $r->push_handlers(PerlFixupHandler => \&manage_cache);
	  return Apache2::Const::DECLINED;
      }

      # Hash hasn't expired, password is ok, clear the stacked handlers

      $r->log->debug("handler: $user cache hit") if $debug;
      $r->set_handlers(PerlAuthenHandler => undef);
      return Apache2::Const::OK;
  }

  # that key is not in cache

  $r->log->debug("handler: user cache miss") if $debug;
  $r->push_handlers(PerlFixupHandler => \&manage_cache);
  return Apache2::Const::DECLINED;
}

# manage_cache: insert new entries into the cache

sub manage_cache {
  my $r = shift;
  my $tmp;

  # Get configuration

  my $ttl   = $r->dir_config('AuthenDBMCache_TTL') || 3600;
  my $debug = (lc($r->dir_config('AuthenDBMCache_Debug')) eq 'on');
  $cache=$tmp if ($tmp = $r->dir_config('AuthenDBMCache_file'));

  # Get response and password

  my ($status, $passwd) = $r->get_basic_auth_pw;

  # Get username and Realm

  my $realm = lc($r->auth_name);
  my $user  = lc($r->user);
  return Apache2::Const::DECLINED  unless ($user);

  # Get all parameters -- current config

  my $config=$r->dir_config(); $config=join(":",%$config);

  # construct a unique key for userid/realm/config/password

  my $key   = Digest("$user $realm $config $passwd");

  $r->log->debug("manage_cache: user=$user") if $debug;

  # Add the key to the cache with an expiration date

  SetCache("$key",time() + $ttl);

  $r->log->debug("manage_cache: $user cache add") if $debug;

  return Apache2::Const::OK;
}

1;

__END__