File Coverage

blib/lib/Apache/AuthCookieDBIRadius.pm
Criterion Covered Total %
statement 10 12 83.3
branch n/a
condition n/a
subroutine 4 4 100.0
pod n/a
total 14 16 87.5


line stmt bran cond sub pod time code
1             #===============================================================================
2             #
3             # Apache::AuthCookieDBIRadius
4             #
5             # An AuthCookie module backed by a DBI database, then to a Radius server.
6             #
7             # Copyright (C) 1999 SF Interactive, Inc. All rights reserved.
8             #
9             # Author: Charles Day
10             # Original Author: Jacob Davies
11             #
12             # This library is free software; you can redistribute it and/or
13             # modify it under the terms of the GNU Lesser General Public
14             # License as published by the Free Software Foundation; either
15             # version 2.1 of the License, or (at your option) any later version.
16             #
17             # This library is distributed in the hope that it will be useful,
18             # but WITHOUT ANY WARRANTY; without even the implied warranty of
19             # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
20             # Lesser General Public License for more details.
21             #
22             # You should have received a copy of the GNU Lesser General Public
23             # License along with this library; if not, write to the Free Software
24             # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
25             #
26             # $Id: AuthCookieDBIRadius.pm,v 1.19 2001/11/14 12:07:01 barracode Exp $
27             #
28             #===============================================================================
29              
30             package Apache::AuthCookieDBIRadius;
31              
32 1     1   11630 use strict;
  1         2  
  1         3590  
33 1     1   35 use 5.004;
  1         5  
  1         47  
34 1     1   6 use vars qw( $VERSION );
  1         9  
  1         95  
35              
36             # $Id: AuthCookieDBIRadius.pm,v 1.19 2001/11/14 12:07:01 barracode Exp $
37             $VERSION = '1.19';
38              
39 1     1   2196 use Apache::AuthCookie;
  0            
  0            
40             use vars qw( @ISA );
41             @ISA = qw( Apache::AuthCookie );
42              
43             use Apache;
44             use Apache::DBI;
45             use Apache::Constants;
46             use Apache::File;
47             use Digest::MD5 qw( md5_hex );
48             use Date::Calc qw( Today_and_Now Add_Delta_DHMS );
49             # Also uses Crypt::CBC if you're using encrypted cookies.
50              
51             # Added IPC::ShareLite.
52             use IPC::ShareLite qw( LOCK_EX LOCK_SH LOCK_UN LOCK_NB );
53              
54             # Added Radius.
55             use Authen::Radius;
56             use Tie::IxHash;
57              
58              
59             #===============================================================================
60             # F U N C T I O N D E C L A R A T I O N S
61             #===============================================================================
62              
63             sub _log_not_set($$);
64             sub _dir_config_var($$);
65             sub _dbi_config_vars($);
66             sub _now_year_month_day_hour_minute_second();
67             sub _percent_encode($);
68             sub _percent_decode($);
69              
70             sub authen_cred($$\@);
71             sub authen_ses_key($$$);
72             sub group($$\@);
73              
74             #===============================================================================
75             # P A C K A G E G L O B A L S
76             #===============================================================================
77              
78             use vars qw( %CIPHERS );
79             # Stores Cipher::CBC objects in $CIPHERS{ idea:AuthName },
80             # $CIPHERS{ des:AuthName } etc.
81              
82             use vars qw( %SECRET_KEYS );
83             # Stores secret keys for MD5 checksums and encryption for each auth realm in
84             # $SECRET_KEYS{ AuthName }.
85              
86             #===============================================================================
87             # S E R V E R S T A R T I N I T I A L I Z A T I O N
88             #===============================================================================
89              
90             BEGIN {
91             my @keyfile_vars = grep {
92             $_ =~ /DBI_SecretKeyFile$/
93             } keys %{ Apache->server->dir_config() };
94             foreach my $keyfile_var ( @keyfile_vars ) {
95             my $keyfile = Apache->server->dir_config( $keyfile_var );
96             my $auth_name = $keyfile_var;
97             $auth_name =~ s/DBI_SecretKeyFile$//;
98             unless ( open( KEY, "<$keyfile" ) ) {
99             Apache::log_error( "Could not open keyfile for $auth_name in file $keyfile" );
100             } else {
101             $SECRET_KEYS{ $auth_name } = ;
102             close KEY;
103             }
104             }
105             }
106              
107             #===============================================================================
108             # P R I V A T E F U N C T I O N S
109             #===============================================================================
110              
111             #-------------------------------------------------------------------------------
112             # _log_not_set -- Log that a particular authentication variable was not set.
113              
114             sub _log_not_set($$)
115             {
116             my( $r, $variable ) = @_;
117             my $auth_name = $r->auth_name;
118             $r->log_error( "Apache::AuthCookieDBIRadius: $variable not set for auth realm
119             $auth_name", $r->uri );
120             }
121              
122             #-------------------------------------------------------------------------------
123             # _dir_config_var -- Get a particular authentication variable.
124              
125             sub _dir_config_var($$)
126             {
127             my( $r, $variable ) = @_;
128             my $auth_name = $r->auth_name;
129             return $r->dir_config( "$auth_name$variable" );
130             }
131              
132             #-------------------------------------------------------------------------------
133             # _dbi_config_vars -- Gets the config variables from the dir_config and logs
134             # errors if required fields were not set, returns undef if any of the fields
135             # had errors or a hash of the values if they were all OK. Takes a request
136             # object.
137              
138             sub _dbi_config_vars($)
139             {
140             my( $r ) = @_;
141              
142             my %c; # config variables hash
143              
144             #
145             #Specifies the DSN for DBI for the database you wish to connect to retrieve
146             #user information. This is required and has no default value.
147              
148             unless ( $c{ DBI_DSN } = _dir_config_var $r, 'DBI_DSN' )
149             {
150             _log_not_set $r, 'DBI_DSN';
151             return undef;
152             }
153              
154             #
155             #The user to log into the database as. This is not required and
156             #defaults to undef.
157              
158             $c{ DBI_user } = _dir_config_var( $r, 'DBI_User' ) || undef;
159              
160             #
161             #The password to use to access the database. This is not required
162             #and defaults to undef.
163              
164             $c{ DBI_password } = _dir_config_var( $r, 'DBI_Password' ) || undef;
165              
166             #
167             #The table that user names and passwords are stored in. This is not
168             #required and defaults to 'users'.
169              
170             $c{ DBI_userstable } = _dir_config_var( $r, 'DBI_UsersTable' ) || 'users';
171              
172             #
173             #The field in the above table that has the user name. This is not
174             #required and defaults to 'user'.
175              
176             $c{ DBI_userfield } = _dir_config_var( $r, 'DBI_UserField' ) || 'user';
177              
178             #
179             #The field in the above table that has the password. This is not
180             #required and defaults to 'password'.
181              
182             $c{ DBI_passwordfield } = _dir_config_var( $r, 'DBI_PasswordField' ) || 'password';
183              
184             #
185             #What kind of hashing is used on the password field in the database. This can
186             #be 'none', 'crypt', or 'md5'. This is not required and defaults to 'none'.
187              
188             $c{ DBI_crypttype } = _dir_config_var( $r, 'DBI_CryptType' ) || 'crypt';
189              
190             #
191             #The table that has the user / group information. This is not required and
192             #defaults to 'groups'.
193              
194             $c{ DBI_groupstable } = _dir_config_var( $r, 'DBI_GroupsTable' ) || 'groups';
195              
196             #
197             #The field in the above table that has the group name. This is not required
198             #and defaults to 'grp' (to prevent conflicts with the SQL reserved word 'group').
199              
200             $c{ DBI_groupfield } = _dir_config_var( $r, 'DBI_GroupField' ) || 'grp';
201              
202             #
203             #The field in the above table that has the user name. This is not required
204             #and defaults to 'user'.
205              
206             $c{ DBI_groupuserfield } = _dir_config_var( $r, 'DBI_GroupUserField' ) || 'user';
207              
208             #
209             #The file that contains the secret key (on the first line of the file). This
210             #is required and has no default value. This key should be owned and only
211             #readable by root. It is read at server startup time.
212             #The key should be long and fairly random. If you want, you
213             #can change it and restart the server, (maybe daily), which will invalidate
214             #all prior-issued tickets.
215              
216             unless ( $c{ DBI_secretkeyfile } = _dir_config_var $r, 'DBI_SecretKeyFile' )
217             {
218             _log_not_set $r, 'DBI_SecretKeyFile';
219             return undef;
220             }
221              
222             #
223             #What kind of encryption to use to prevent the user from looking at the fields
224             #in the ticket we give them. This is almost completely useless, so don't
225             #switch it on unless you really know you need it. It does not provide any
226             #protection of the password in transport; use SSL for that. It can be 'none',
227             #'des', 'idea', 'blowfish', or 'blowfish_pp'.
228             #This is not required and defaults to 'none'.'
229              
230             $c{ DBI_encryptiontype } = _dir_config_var( $r, 'DBI_EncryptionType' ) || 'none';
231              
232             # If we used encryption we need to pull in Crypt::CBC.
233             if ( $c{ DBI_encryptiontype } ne 'none' )
234             {
235             require Crypt::CBC;
236             }
237              
238             #
239             #How long tickets are good for after being issued. Note that presently
240             #Apache::AuthCookie does not set a client-side expire time, which means that
241             #most clients will only keep the cookie until the user quits the browser.
242             #However, if you wish to force people to log in again sooner than that, set
243             #this value. This can be 'forever' or a life time specified as:
244             #DD-hh-mm-ss -- Days, hours, minute and seconds to live.
245             #This is not required and defaults to '00-12-00-00' or 12 hours.
246             $c{ DBI_sessionlifetime } = _dir_config_var( $r, 'DBI_SessionLifetime' ) || '00-12-00-00';
247              
248             # Custom variables from httpd.conf.
249             $c{ DBI_a } = _dir_config_var( $r, 'DBI_a' ) || 'off';
250             $c{ DBI_b } = _dir_config_var( $r, 'DBI_b' ) || 'off';
251             $c{ DBI_c } = _dir_config_var( $r, 'DBI_c' ) || 'off';
252             $c{ DBI_d } = _dir_config_var( $r, 'DBI_d' ) || 'off';
253             $c{ DBI_e } = _dir_config_var( $r, 'DBI_e' ) || 'off';
254             $c{ DBI_f } = _dir_config_var( $r, 'DBI_f' ) || 'off';
255             $c{ DBI_g } = _dir_config_var( $r, 'DBI_g' ) || 'off';
256              
257             # other fields from httpd.conf.
258             $c{ DBI_activeuser } = _dir_config_var( $r, 'DBI_activeuser' ) || 'on';
259             $c{ DBI_log_field } = _dir_config_var( $r, 'DBI_log_field' ) || 'last_access';
260              
261             # Radius variables.
262             #$c{ DBI_Radius_host } = _dir_config_var( $r, 'DBI_Radius_host' ) || 'none';
263             #$c{ DBI_Radius_port } = _dir_config_var( $r, 'DBI_Radius_port' ) || '1645';
264             #$c{ DBI_Radius_secret } = _dir_config_var( $r, 'DBI_Radius_secret' ) || 'none';
265             #$c{ DBI_Radius_timeout } = _dir_config_var( $r, 'DBI_Radius_timeout' ) || 45;
266              
267             return %c;
268             }
269              
270             #-------------------------------------------------------------------------------
271             # _now_year_month_day_hour_minute_second -- Return a string with the time in
272             # this order separated by dashes.
273              
274             sub _now_year_month_day_hour_minute_second()
275             {
276             return sprintf '%04d-%02d-%02d-%02d-%02d-%02d', Today_and_Now;
277             }
278              
279             #-------------------------------------------------------------------------------
280             # _percent_encode -- Percent-encode (like URI encoding) any non-alphanumberics
281             # in the supplied string.
282              
283             sub _percent_encode($)
284             {
285             my( $str ) = @_;
286             $str =~ s/([^\w])/ uc sprintf '%%%02x', ord $1 /eg;
287             return $str;
288             }
289              
290             #-------------------------------------------------------------------------------
291             # _percent_decode -- Percent-decode (like URI decoding) any %XX sequences in
292             # the supplied string.
293              
294             sub _percent_decode($)
295             {
296             my( $str ) = @_;
297             $str =~ s/%([0-9a-fA-F]{2})/ pack( "c",hex( $1 ) ) /ge;
298             return $str;
299             }
300              
301             #===============================================================================
302             # P U B L I C F U N C T I O N S
303             #===============================================================================
304              
305             #-------------------------------------------------------------------------------
306             # Take the credentials for a user and check that they match; if so, return
307             # a new session key for this user that can be stored in the cookie.
308             # If there is a problem, return a bogus session key.
309              
310             sub authen_cred($$\@)
311             {
312             my( $self, $r, @credentials ) = @_;
313              
314             my $auth_name = $r->auth_name;
315              
316             # Username goes in credential_0
317             my $user = $credentials[ 0 ];
318             unless ( $user =~ /^.+$/ )
319             {
320             $r->log_reason( "Apache::AuthCookieDBIRadius: no username supplied for auth realm $auth_name", $r->uri );
321             return 'ERROR! No Username Supplied';
322             #return 'bad';
323             }
324             # Password goes in credential_1
325             my $password = $credentials[ 1 ];
326              
327             # create $temp for error messages.
328             my $temp = $password;
329            
330             unless ( $password =~ /^.+$/ )
331             {
332             $r->log_reason( "Apache::AuthCookieDBIRadius: no password supplied for auth realm $auth_name", $r->uri );
333             return 'ERROR! No Password Supplied';
334             #return 'bad';
335             }
336              
337             # get the configuration information.
338             my %c = _dbi_config_vars $r;
339              
340             # Lock out after 5 failed consecutive attempts. Unlock when the next IP comes in.
341             my $attempts = 1;
342             my @split = ();
343             my $share = new IPC::ShareLite( -key => 'AuthCookie',
344             -create => 'yes',
345             -destroy => 'no',
346             -size => 25 );
347              
348             # Retrieve value from memory.
349             my $result = $share->fetch;
350             if ($result =~ $ENV{REMOTE_ADDR})
351             {
352             @split = split(/\:/,$result);
353             $attempts = $split[1]+1;
354             if ($split[1] > 5)
355             {
356             $r->log_reason( "Apache::AuthCookieDBIRadius: Security Error! Too many attempts to auth realm $auth_name", $r->uri );
357             return "ERROR! Security error. Too many attempts.";
358             }
359             }
360             # Store new value.
361             $result = $share->store("$ENV{REMOTE_ADDR}:$attempts");
362              
363             # Look up user in database.
364             my $dbh = DBI->connect( $c{ DBI_DSN },
365             $c{ DBI_user }, $c{ DBI_password } );
366             unless ( defined $dbh )
367             {
368             $r->log_reason( "Apache::AuthCookieDBIRadius: couldn't connect to $c{ DBI_DSN } for auth realm $auth_name", $r->uri );
369             return 'ERROR! Internal Server Error (111). Please contact us immediately so we can fix this problem.';
370             #return 'bad';
371             }
372             my $cmd = "SELECT $c{DBI_passwordfield},activeuser,a,b,c,d,e,f,g FROM $c{DBI_userstable} WHERE $c{DBI_userfield} = @{[ $dbh->quote($user) ]}";
373              
374             $result = $dbh->prepare($cmd);
375             $result->execute;
376              
377             my @row = $result->fetchrow_array;
378              
379             # debug line.
380             #$r->log_reason( "Apache::AuthCookieDBIRadius: results from database query: row = @row for user $user for auth realm $auth_name", $r->uri );
381              
382             my $crypted_password = $row[0];
383             my $activeuser = $row[1];
384             my $a = $row[2];
385             my $b = $row[3];
386             my $c = $row[4];
387             my $d = $row[5];
388             my $e = $row[6];
389             my $f = $row[7];
390             my $g = $row[8];
391              
392             #unless ( defined $crypted_password )
393             if ( !$crypted_password )
394             {
395             ## Not in DBI database, let's try Radius.
396             #$r->log_reason( "Apache::AuthCookieDBIRadius: couldn't select password from $c{DBI_DSN}, $c{DBI_userstable}, $c{DBI_userfield} for user $user for auth realm $auth_name, lets try Radius", $r->uri );
397             #
398             ## Create the radius connection.
399             #my $radius = Authen::Radius->new(
400             # Host => "$c{ DBI_Radius_host }:$c{ DBI_Radius_port }",
401             # Secret => $c{ DBI_Radius_secret },
402             # TimeOut => $c{ DBI_Radius_timeout });
403             #
404             ## Error if we can't connect.
405             #if (!defined $radius)
406             #{
407             # $r->log_reason("Apache::AuthCookieDBIRadius: failed to connect to Radius host $c{ DBI_Radius_host }, Radius port $c{ DBI_Radius_port }", $r->uri );
408             # return 'ERROR! Internal Server Error (222). Please contact us immediately so we can fix this problem.';
409             # #return 'bad';
410             #}
411             ## Do the actual check.
412             #if ($radius->check_pwd($user,$password))
413             #{
414             # # Passed.
415             # $r->log_reason("Apache::AuthCookieDBIRadius: User $user in Radius and password matches", $r->uri);
416             #
417             # # Must be an employee, give them everything.
418             # $activeuser = 'y';
419             # $a = 'y';
420             # $b = 'y';
421             # $c = 'y';
422             # $d = 'y';
423             # $e = 'y';
424             # $f = 'y';
425             # $g = 'y';
426             #}
427             #else
428             #{
429             # Radius failed, return to login page.
430             $r->log_reason("Apache::AuthCookieDBIRadius Radius authentication failed for user $user and password $password", $r->uri);
431             return 'ERROR! Authentication Failure.';
432             #return 'bad';
433             #}
434             }
435              
436             else
437             {
438             # Return unless the passwords match.
439             if ( lc $c{ DBI_crypttype } eq 'none' )
440             {
441             unless ( $password eq $crypted_password )
442             {
443             $r->log_reason( "Apache::AuthCookieDBIRadius: plaintext passwords didn't match for user $user, password = $password, crypted_password = $crypted_password for auth realm $auth_name", $r->uri );
444             return 'ERROR! Password did not match.';
445             #return 'bad';
446             }
447             }
448             elsif ( lc $c{ DBI_crypttype } eq 'crypt' )
449             {
450             my $salt = substr $crypted_password, 0, 2;
451             unless ( crypt( $password, $salt ) eq $crypted_password )
452             {
453             $r->log_reason( "Apache::AuthCookieDBIRadius: crypted passwords didn't match for user $user, password supplied = $temp for auth realm $auth_name", $r->uri );
454             return 'ERROR! Password did not match.';
455             #return 'bad';
456             }
457             }
458             elsif ( lc $c{ DBI_crypttype } eq 'md5' )
459             {
460             unless ( md5_hex( $password ) eq $crypted_password )
461             {
462             $r->log_reason( "Apache::AuthCookieDBIRadius: MD5 passwords didn't match for user $user for auth realm $auth_name", $r->uri );
463             return 'ERROR! Password did not match.';
464             #return 'bad';
465             }
466             }
467             }
468              
469             # Create the expire time for the ticket.
470             my $expire_time;
471             # expire time in a zillion years if it's forever.
472             if ( lc $c{ DBI_sessionlifetime } eq 'forever' ) {
473             $expire_time = '9999-01-01-01-01-01';
474             } else {
475             my( $deltaday, $deltahour, $deltaminute, $deltasecond )
476             = split /-/, $c{ DBI_sessionlifetime };
477             # Figure out the expire time.
478             $expire_time = sprintf(
479             '%04d-%02d-%02d-%02d-%02d-%02d',
480             Add_Delta_DHMS( Today_and_Now,
481             $deltaday, $deltahour,
482             $deltaminute, $deltasecond )
483             );
484             }
485              
486             # Now we need to %-encode non-alphanumberics in the username so we
487             # can stick it in the cookie safely.
488             my $enc_user = _percent_encode $user;
489              
490             # OK, now we stick the username and the current time and the expire
491             # time together to make the public part of the session key:
492             my $current_time = _now_year_month_day_hour_minute_second;
493              
494             #my $public_part = "$enc_user:$current_time:$expire_time";
495             my $public_part = "$enc_user:$current_time:$expire_time:$activeuser:$a:$b:$c:$d:$e:$f:$g";
496              
497             # Now we calculate the hash of this and the secret key and then
498             # calculate the hash of *that* and the secret key again.
499             my $secret_key = $SECRET_KEYS{ $auth_name };
500              
501             unless ( defined $secret_key )
502             {
503             $r->log_reason( "Apache::AuthCookieDBIRadius: didn't have the secret key for auth realm $auth_name", $r->uri );
504             return 'ERROR! Internal Server Error (333). Please contact us immediately so we can fix this problem.';
505             #return 'bad';
506             }
507             my $hash = md5_hex( join ':', $secret_key, md5_hex(
508             join ':', $public_part, $secret_key
509             ) );
510              
511             # Now we add this hash to the end of the public part.
512             my $session_key = "$public_part:$hash";
513              
514             # Now we encrypt this and return it.
515             my $encrypted_session_key;
516             if ( $c{ DBI_encryptiontype } eq 'none' )
517             {
518             $encrypted_session_key = $session_key;
519             }
520             elsif ( lc $c{ DBI_encryptiontype } eq 'des' )
521             {
522             $CIPHERS{ "des:$auth_name" }
523             ||= Crypt::CBC->new( $secret_key, 'DES' );
524             $encrypted_session_key = $CIPHERS{
525             "des:$auth_name"
526             }->encrypt_hex( $session_key );
527             }
528             elsif ( lc $c{ DBI_encryptiontype } eq 'idea' )
529             {
530             $CIPHERS{ "idea:$auth_name" }
531             ||= Crypt::CBC->new( $secret_key, 'IDEA' );
532             $encrypted_session_key = $CIPHERS{
533             "idea:$auth_name"
534             }->encrypt_hex( $session_key );
535             }
536             elsif ( lc $c{ DBI_encryptiontype } eq 'blowfish' )
537             {
538             $CIPHERS{ "blowfish:$auth_name" }
539             ||= Crypt::CBC->new( $secret_key, 'Blowfish' );
540             $encrypted_session_key = $CIPHERS{
541             "blowfish:$auth_name"
542             }->encrypt_hex( $session_key );
543             }
544              
545             # update log_field field.
546             if ($c{ DBI_log_field })
547             {
548             my $cmd = "UPDATE $c{DBI_userstable} SET $c{DBI_log_field} = 'NOW' WHERE $c{DBI_userfield} = \'$user\';";
549              
550             unless ($dbh->do($cmd))
551             {
552             $r->log_reason("Apache::AuthCookieDBIRadius: can not update $c{DBI_log_field}: $DBI::errstr: cmd=$cmd", $r->uri);
553             $dbh->disconnect;
554             return SERVER_ERROR;
555             }
556             $dbh->disconnect;
557             }
558              
559             return $encrypted_session_key;
560             }
561              
562              
563             # Take a session key and check that it is still valid; if so, return the user.
564             sub authen_ses_key($$$)
565             {
566             my( $self, $r, $encrypted_session_key ) = @_;
567              
568             my $auth_name = $r->auth_name;
569              
570             # Get the configuration information.
571             my %c = _dbi_config_vars $r;
572              
573             # Get the secret key.
574             my $secret_key = $SECRET_KEYS{ $auth_name };
575              
576             unless ( defined $secret_key ) {
577             $r->log_reason( "Apache::AuthCookieDBIRadius: didn't the secret key from for auth realm $auth_name", $r->uri );
578             return undef;
579             }
580            
581             # Decrypt the session key.
582             my $session_key;
583             if ( $c{ DBI_encryptiontype } eq 'none' )
584             {
585             $session_key = $encrypted_session_key;
586             }
587             else
588             {
589             # Check that this looks like an encrypted hex-encoded string.
590             unless ( $encrypted_session_key =~ /^[0-9a-fA-F]+$/ )
591             {
592             $r->log_reason( "Apache::AuthCookieDBIRadius: encrypted session key $encrypted_session_key doesn't look like it's properly hex-encoded for auth realm $auth_name", $r->uri );
593             return undef;
594             }
595              
596             # Get the cipher from the cache, or create a new one if the
597             # cached cipher hasn't been created, & decrypt the session key.
598             my $cipher;
599             if ( lc $c{ DBI_encryptiontype } eq 'des' ) {
600             $cipher = $CIPHERS{ "des:$auth_name" }
601             ||= Crypt::CBC->new( $secret_key, 'DES' );
602             } elsif ( lc $c{ DBI_encryptiontype } eq 'idea' ) {
603             $cipher = $CIPHERS{ "idea:$auth_name" }
604             ||= Crypt::CBC->new( $secret_key, 'IDEA' );
605             } elsif ( lc $c{ DBI_encryptiontype } eq 'blowfish' ) {
606             $cipher = $CIPHERS{ "blowfish:$auth_name" }
607             ||= Crypt::CBC->new( $secret_key, 'Blowfish' );
608             } elsif ( lc $c{ DBI_encryptiontype } eq 'blowfish_pp' ) {
609             $cipher = $CIPHERS{ "blowfish_pp:$auth_name" }
610             ||= Crypt::CBC->new( $secret_key, 'Blowfish_PP' );
611             } else {
612             $r->log_reason( "Apache::AuthCookieDBIRadius: unknown encryption type $c{ DBI_encryptiontype } for auth realm $auth_name", $r->uri );
613             return undef;
614             }
615             $session_key = $cipher->decrypt_hex( $encrypted_session_key );
616             }
617            
618             # Break up the session key.
619             my( $enc_user,$issue_time,$expire_time,$activeuser,$a,$b,$c,$d,$e,$f,$g,$supplied_hash )
620             = split /:/, $session_key;
621             # Let's check that we got passed sensible values in the cookie.
622             unless ( $enc_user =~ /^[a-zA-Z0-9_\%]+$/ )
623             {
624             $r->log_reason( "Apache::AuthCookieDBIRadius: bad percent-encoded user $enc_user recovered from session ticket for auth_realm $auth_name", $r->uri );
625             return undef;
626             }
627              
628             # decode the user
629             my $user = _percent_decode $enc_user;
630             unless ( $issue_time =~ /^\d{4}-\d{2}-\d{2}-\d{2}-\d{2}-\d{2}$/ )
631             {
632             $r->log_reason( "Apache::AuthCookieDBIRadius: bad issue time $issue_time recovered from ticket for user $user for auth_realm $auth_name", $r->uri );
633             return undef;
634             }
635             unless ( $expire_time =~ /^\d{4}-\d{2}-\d{2}-\d{2}-\d{2}-\d{2}$/ )
636             {
637             $r->log_reason( "Apache::AuthCookieDBIRadius: bad expire time $expire_time recovered from ticket for user $user for auth_realm $auth_name", $r->uri );
638             return undef;
639             }
640             unless ( $supplied_hash =~ /^[0-9a-fA-F]{32}$/ )
641             {
642             $r->log_reason( "Apache::AuthCookieDBIRadius: bad hash $supplied_hash recovered from ticket for user $user for auth_realm $auth_name", $r->uri );
643             return undef;
644             }
645              
646             # Calculate the hash of the user, issue time, expire_time and
647             # the secret key and then the hash of that and the secret key again.
648             my $hash = md5_hex( join ':', $secret_key, md5_hex(
649             join ':', $enc_user,$issue_time,$expire_time,$activeuser,$a,$b,$c,$d,$e,$f,$g,$secret_key
650             ) );
651              
652             # Compare it to the hash they gave us.
653             unless ( $hash eq $supplied_hash ) {
654             $r->log_reason( "Apache::AuthCookieDBIRadius: hash in cookie did not match calculated hash of contents for user $user for auth realm $auth_name", $r->uri );
655             return undef;
656             }
657              
658             # Check that their session hasn't timed out.
659             if ( _now_year_month_day_hour_minute_second gt $expire_time )
660             {
661             $r->log_reason( "Apache:AuthCookieDBIRadius: expire time $expire_time has passed for user $user for auth realm $auth_name", $r->uri );
662             return undef;
663             }
664              
665             # If we're being paranoid about timing-out long-lived sessions,
666             # check that the issue time + the current (server-set) session lifetime
667             # hasn't passed too (in case we issued long-lived session tickets
668             # in the past that we want to get rid of). *** DEBUG ***
669             # if ( lc $c{ DBI_AlwaysUseCurrentSessionLifetime } eq 'on' ) {
670              
671             # check the directory to see if user has correct permissions here.
672             $auth_name = $r->auth_name;
673              
674             # Get the configuration information.
675             %c = _dbi_config_vars $r;
676              
677             # a
678             if ($c{DBI_a} eq "on" && $a ne 'y')
679             {
680             $r->log_reason( "Apache::AuthCookieDBIRadius: DBI_a = on but a <> y for user $user for auth realm $auth_name", $r->uri);
681             return undef;
682             }
683             # b
684             if ($c{DBI_b} eq "on" && $b ne 'y')
685             {
686             $r->log_reason( "Apache::AuthCookieDBIRadius: DBI_b = on but b <> y for user $user for auth realm $auth_name", $r->uri);
687             return undef;
688             }
689             # c
690             if ($c{DBI_c} eq "on" && $c ne 'y')
691             {
692             $r->log_reason( "Apache::AuthCookieDBIRadius: DBI_c = on but c <> y for user $user for auth realm $auth_name", $r->uri);
693             return undef;
694             }
695             # d
696             if ($c{DBI_d} eq "on" && $d ne 'y')
697             {
698             $r->log_reason( "Apache::AuthCookieDBIRadius: DBI_d = on but d <> y for user $user for auth realm $auth_name", $r->uri);
699             return undef;
700             }
701             # e
702             if ($c{DBI_e} eq "on" && $e ne 'y')
703             {
704             $r->log_reason( "Apache::AuthCookieDBIRadius: DBI_e = on but e <> y for user $user for auth realm $auth_name", $r->uri);
705             return undef;
706             }
707             # f
708             if ($c{DBI_f} eq "on" && $f ne 'y')
709             {
710             $r->log_reason( "Apache::AuthCookieDBIRadius: DBI_f = on but f <> y for user $user for auth realm $auth_name", $r->uri);
711             return undef;
712             }
713             # g
714             if ($c{DBI_g} eq "on" && $g ne 'y')
715             {
716             $r->log_reason( "Apache::AuthCookieDBIRadius: DBI_g = on but g <> y for user $user for auth realm $auth_name", $r->uri);
717             return undef;
718             }
719             # activeuser
720             if ($c{DBI_activeuser} eq "on" && $activeuser ne 'y')
721             {
722             $r->log_reason( "Apache::AuthCookieDBIRadius: DBI_activeuser = on but activeuser <> y for user $user for auth realm $auth_name", $r->uri);
723             return undef;
724             }
725              
726             # They must be okay, so return the user.
727             $r->subprocess_env('TICKET', $user);
728              
729             return $user;
730             }
731              
732             #-------------------------------------------------------------------------------
733             # Take a list of groups and make sure that the current remote user is a member
734             # of one of them.
735              
736             sub group($$\@)
737             {
738             my( $self, $r, @groups ) = @_;
739              
740             my $auth_name = $r->auth_name;
741              
742             # Get the configuration information.
743             my %c = _dbi_config_vars $r;
744              
745             my $user = $r->connection->user;
746              
747             # See if we have a row in the groups table for this user/group.
748             my $dbh = DBI->connect( $c{ DBI_DSN },
749             $c{ DBI_user }, $c{ DBI_password } );
750             unless ( defined $dbh ) {
751             $r->log_reason( "Apache::AuthCookieDBIRadius: couldn't connect to $c{ DBI_DSN } for auth realm $auth_name", $r->uri );
752             return undef;
753             }
754              
755             # Now loop through all the groups to see if we're a member of any:
756             my $result = $dbh->prepare( <<"EOS" );
757             SELECT $c{ DBI_groupuserfield }
758             FROM $c{ DBI_groupstable }
759             WHERE $c{ DBI_groupfield } = ?
760             AND $c{ DBI_groupuserfield } = ?
761             EOS
762             foreach my $group ( @groups ) {
763             $result->execute( $group, $user );
764             return OK if ( $result->fetchrow_array );
765             }
766             $r->log_reason( "Apache::AuthCookieDBIRadius: user $user was not a member of any of the required groups @groups for auth realm $auth_name", $r->uri );
767             return FORBIDDEN;
768             }
769              
770             1;
771              
772             __END__