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


line stmt bran cond sub pod time code
1             # $Id: AuthenDBMCache.pm,v 1.17 2006/03/02 21:13:21 reggers Exp $
2             #
3             # Author : Reg Quinton
4             # Created On : 23-Sep-2002
5             # Derivation : from AuthenCache by Jason Bodnar, Christian Gilmore
6             # Status : Functional
7             #
8             # PURPOSE
9             # User Authentication Cache implemented in a DBM database.
10              
11             # Package name
12              
13             package Apache2::AuthenDBMCache;
14              
15             # Required libraries
16              
17 1     1   2275 use mod_perl2 ;
  0            
  0            
18             use Apache2::Access ;
19             use Apache2::Log ;
20             use Apache2::RequestRec ;
21             use Apache2::RequestUtil ;
22             use Apache2::Const -compile => qw(HTTP_UNAUTHORIZED HTTP_INTERNAL_SERVER_ERROR DECLINED HTTP_FORBIDDEN OK) ;
23             use APR::Table ;
24             use Carp;
25             use strict;
26             use warnings FATAL => 'all';
27              
28             # Global variables
29              
30             $Apache2::AuthenDBMCache::VERSION = '0.01';
31              
32             # local subroutines and data not exported to anyone
33              
34             my($cache)= "/var/cache/authen-web/cache";
35              
36             # key index to value -- an expiration date.
37              
38             sub GetCache {
39             my (%DBM); my($key)=@_;
40              
41             croak "No access to $cache"
42             unless dbmopen(%DBM,$cache,0600);
43              
44             my ($tmp)=$DBM{$key}; dbmclose(%DBM);
45              
46             return ($tmp);
47             }
48              
49             sub SetCache {
50             my (%DBM); my ($key,$val)=@_;
51              
52             croak "No access to $cache"
53             unless dbmopen(%DBM,$cache,0600);
54              
55             $DBM{$key}=$val; dbmclose(%DBM);
56             }
57              
58             sub ExpireCache {
59             my ($file) = @_;
60             $cache=$file if $file;
61              
62             my (%DBM,$key,$now);
63              
64             croak "No access to $cache"
65             unless dbmopen(%DBM,$cache,0600);
66              
67             $now=time();
68              
69             foreach $key (keys %DBM) {
70             delete $DBM{$key} if $DBM{$key} < $now;
71             }
72              
73             dbmclose(%DBM);
74              
75             }
76              
77             # squish userid, password, config and realm into a hash
78              
79             sub Digest {
80             use Digest::MD5;
81              
82             my ($string)=Digest::MD5->md5_hex(@_);
83             $string=~ s/[^0-9a-zA-Z]//g;
84             return($string);
85             }
86              
87             # handler: hook into Apache2/mod_perl2 API
88              
89             sub handler {
90             my $r = shift;
91             my $tmp;
92              
93             # Get response and password
94              
95             my($status, $passwd) = $r->get_basic_auth_pw;
96             return Apache2::Const::OK unless $r->is_initial_req;
97             return $status unless ($status == Apache2::Const::OK); # e.g. HTTP_UNAUTHORIZED
98             # Get configuration... are we debugging?
99              
100             my $debug = (lc($r->dir_config('AuthenDBMCache_Debug')) eq 'on');
101             $cache=$tmp if ($tmp = $r->dir_config('AuthenDBMCache_file'));
102              
103             # Get username and Realm
104              
105             my $realm = lc($r->auth_name);
106             my $user = lc($r->user);
107             return Apache2::Const::DECLINED unless ($user);
108              
109             # Get all parameters -- current config (to limit cache poison).
110              
111             my $config=$r->dir_config(); $config=join(":",%$config);
112              
113             # construct a unique key for userid/realm/config/password
114              
115             my $key = Digest("$user $realm $config $passwd");
116              
117             $r->log->debug("handler: user=$user") if $debug;
118              
119             # if there is an expiration date for that key
120              
121             if (my $exp = GetCache("$key")) {
122             if ($exp < time()) {
123             $r->log->debug("handler: user cache stale") if $debug;
124             $r->push_handlers(PerlFixupHandler => \&manage_cache);
125             return Apache2::Const::DECLINED;
126             }
127              
128             # Hash hasn't expired, password is ok, clear the stacked handlers
129              
130             $r->log->debug("handler: $user cache hit") if $debug;
131             $r->set_handlers(PerlAuthenHandler => undef);
132             return Apache2::Const::OK;
133             }
134              
135             # that key is not in cache
136              
137             $r->log->debug("handler: user cache miss") if $debug;
138             $r->push_handlers(PerlFixupHandler => \&manage_cache);
139             return Apache2::Const::DECLINED;
140             }
141              
142             # manage_cache: insert new entries into the cache
143              
144             sub manage_cache {
145             my $r = shift;
146             my $tmp;
147              
148             # Get configuration
149              
150             my $ttl = $r->dir_config('AuthenDBMCache_TTL') || 3600;
151             my $debug = (lc($r->dir_config('AuthenDBMCache_Debug')) eq 'on');
152             $cache=$tmp if ($tmp = $r->dir_config('AuthenDBMCache_file'));
153              
154             # Get response and password
155              
156             my ($status, $passwd) = $r->get_basic_auth_pw;
157              
158             # Get username and Realm
159              
160             my $realm = lc($r->auth_name);
161             my $user = lc($r->user);
162             return Apache2::Const::DECLINED unless ($user);
163              
164             # Get all parameters -- current config
165              
166             my $config=$r->dir_config(); $config=join(":",%$config);
167              
168             # construct a unique key for userid/realm/config/password
169              
170             my $key = Digest("$user $realm $config $passwd");
171              
172             $r->log->debug("manage_cache: user=$user") if $debug;
173              
174             # Add the key to the cache with an expiration date
175              
176             SetCache("$key",time() + $ttl);
177              
178             $r->log->debug("manage_cache: $user cache add") if $debug;
179              
180             return Apache2::Const::OK;
181             }
182              
183             1;
184              
185             __END__