File Coverage

blib/lib/Apache/AuthCookieLDAP.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::AuthCookieLDAP
4             #
5             # An AuthCookie module backed by a LDAP database.
6             #
7             # Based on Apache::AuthCookieDBI by Jacob Davies
8             #
9             # Author: Bjorn Ardo
10             #
11             # This library is free software; you can redistribute it and/or
12             # modify it under the terms of the GNU Lesser General Public
13             # License as published by the Free Software Foundation; either
14             # version 2.1 of the License, or (at your option) any later version.
15             #
16             # This library is distributed in the hope that it will be useful,
17             # but WITHOUT ANY WARRANTY; without even the implied warranty of
18             # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
19             # Lesser General Public License for more details.
20             #
21             # You should have received a copy of the GNU Lesser General Public
22             # License along with this library; if not, write to the Free Software
23             # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
24             #
25             #
26             #===============================================================================
27              
28             package Apache::AuthCookieLDAP;
29              
30 1     1   889 use strict;
  1         3  
  1         41  
31 1     1   25 use 5.004;
  1         4  
  1         48  
32 1     1   6 use vars qw( $VERSION );
  1         7  
  1         105  
33             ( $VERSION ) = '$Revision: 0.03 $' =~ /([\d.]+)/;
34              
35 1     1   1930 use Apache::AuthCookie;
  0            
  0            
36             use vars qw( @ISA );
37             @ISA = qw( Apache::AuthCookie );
38              
39             use Apache;
40             use Apache::Constants;
41             use Apache::File;
42             use Digest::MD5 qw( md5_hex );
43             use Date::Calc qw( Today_and_Now Add_Delta_DHMS );
44             # Also uses Crypt::CBC if you're using encrypted cookies.
45             use Net::LDAP qw(LDAP_SUCCESS);
46              
47             #===============================================================================
48             # F U N C T I O N D E C L A R A T I O N S
49             #===============================================================================
50              
51             sub _log_not_set($$);
52             sub _dir_config_var($$);
53             sub _dbi_config_vars($);
54             sub _now_year_month_day_hour_minute_second();
55             sub _percent_encode($);
56             sub _percent_decode($);
57              
58             sub authen_cred($$\@);
59             sub authen_ses_key($$$);
60             sub group($$$);
61              
62             #===============================================================================
63             # P A C K A G E G L O B A L S
64             #===============================================================================
65              
66             use vars qw( %CIPHERS );
67             # Stores Cipher::CBC objects in $CIPHERS{ idea:AuthName },
68             # $CIPHERS{ des:AuthName } etc.
69              
70             use vars qw( %SECRET_KEYS );
71             # Stores secret keys for MD5 checksums and encryption for each auth realm in
72             # $SECRET_KEYS{ AuthName }.
73              
74             #===============================================================================
75             # 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
76             #===============================================================================
77              
78             BEGIN {
79             my @keyfile_vars = grep {
80             $_ =~ /LDAP_SecretKeyFile$/
81             } keys %{ Apache->server->dir_config() };
82             foreach my $keyfile_var ( @keyfile_vars ) {
83             my $keyfile = Apache->server->dir_config( $keyfile_var );
84             my $auth_name = $keyfile_var;
85             $auth_name =~ s/LDAP_SecretKeyFile$//;
86             unless ( open( KEY, "<$keyfile" ) ) {
87             Apache::log_error( "Could not open keyfile for $auth_name in file $keyfile" );
88             } else {
89             $SECRET_KEYS{ $auth_name } = ;
90             close KEY;
91             }
92             }
93             }
94              
95             #===============================================================================
96             # P E R L D O C
97             #===============================================================================
98              
99             =head1 NAME
100              
101             Apache::AuthCookieLDAP - An AuthCookie module backed by a LDAP database.
102              
103             =head1 VERSION
104              
105             $Revision: 0.02 $
106              
107             =head1 SYNOPSIS
108              
109             Not correct!!!
110              
111              
112             # In httpd.conf or .htaccess
113             PerlModule Apache::AuthCookieLDAP
114             PerlSetVar WhatEverPath /
115             PerlSetVar WhatEverLoginScript /login.pl
116              
117             # Optional, to share tickets between servers.
118             PerlSetVar WhatEverDomain .domain.com
119            
120             # These must be set
121             PerlSetVar WhatEverLDAP_DN "o=foo.com"
122             PerlSetVar WhatEverLDAP_SecretKeyFile /etc/httpd/acme.com.key
123             PerlSetVar WhatEverLDAP_User uid
124              
125              
126             # These are optional, the module sets sensible defaults.
127              
128             PerlSetVar WhatEverLDAP_filter F=on
129             PerlSetVar WhatEverDBI_GroupsTable "groups"
130             PerlSetVar WhatEverDBI_GroupField "grp"
131             PerlSetVar WhatEverDBI_GroupUserField "user"
132              
133             PerlSetVar WhatEverLDAP_host ldap.bank.com
134             PerlSetVar WhatEverLDAP_EncryptionType "none"
135             PerlSetVar WhatEverLDAP_SessionLifetime 00-24-00-00
136              
137             # Protected by AuthCookieLDAP.
138            
139             AuthType Apache::AuthCookieLDAP
140             AuthName WhatEver
141             PerlAuthenHandler Apache::AuthCookieLDAP->authenticate
142             PerlAuthzHandler Apache::AuthCookieLDAP->authorize
143             require valid-user
144             # or you can require users:
145             require user jacob
146              
147             # You can optionally require groups.
148             require group system
149            
150              
151             # Login location. *** DEBUG *** I still think this is screwy
152            
153             AuthType Apache::AuthCookieLDAP
154             AuthName WhatEver
155             SetHandler perl-script
156             PerlHandler Apache::AuthCookieLDAP->login
157            
158              
159             =head1 DESCRIPTION
160              
161             This module is an authentication handler that uses the basic mechanism provided
162             by Apache::AuthCookie with a LDAP database for ticket-based protection. It
163             is based on two tokens being provided, a username and password, which can
164             be any strings (there are no illegal characters for either). The username is
165             used to set the remote user as if Basic Authentication was used.
166              
167             On an attempt to access a protected location without a valid cookie being
168             provided, the module prints an HTML login form (produced by a CGI or any
169             other handler; this can be a static file if you want to always send people
170             to the same entry page when they log in). This login form has fields for
171             username and password. On submitting it, the username and password are looked
172             up in the LDAP database. If this succeeds, the user is issued
173             a ticket. This ticket contains the username, an issue time, an expire time,
174             and an MD5 checksum of those and a secret key for the server. It can
175             optionally be encrypted before returning it to the client in the cookie;
176             encryption is only useful for preventing the client from seeing the expire
177             time. If you wish to protect passwords in transport, use an SSL-encrypted
178             connection. The ticket is given in a cookie that the browser stores.
179              
180             After a login the user is redirected to the location they originally wished
181             to view (or to a fixed page if the login "script" was really a static file).
182              
183             On this access and any subsequent attempt to access a protected document, the
184             browser returns the ticket to the server. The server unencrypts it if
185             encrypted tickets are enabled, then extracts the username, issue time, expire
186             time and checksum. A new checksum is calculated of the username, issue time,
187             expire time and the secret key again; if it agrees with the checksum that
188             the client supplied, we know that the data has not been tampered with. We
189             next check that the expire time has not passed. If not, the ticket is still
190             good, so we set the username.
191              
192             Authorization checks then check that any "require valid-user" or "require
193             user jacob" settings are passed. If all these
194             checks pass, the document requested is displayed.
195              
196             If a ticket has expired or is otherwise invalid it is cleared in the browser
197             and the login form is shown again.
198              
199             =cut
200              
201             #===============================================================================
202             # P R I V A T E F U N C T I O N S
203             #===============================================================================
204              
205             #-------------------------------------------------------------------------------
206             # _log_not_set -- Log that a particular authentication variable was not set.
207              
208             sub _log_not_set($$)
209             {
210             my( $r, $variable ) = @_;
211             my $auth_name = $r->auth_name;
212             $r->log_error( "Apache::AuthCookieLDAP: $variable not set for auth realm
213             $auth_name", $r->uri );
214             }
215              
216             #-------------------------------------------------------------------------------
217             # _dir_config_var -- Get a particular authentication variable.
218              
219             sub _dir_config_var($$)
220             {
221             my( $r, $variable ) = @_;
222             my $auth_name = $r->auth_name;
223             return $r->dir_config( "$auth_name$variable" );
224             }
225              
226             #-------------------------------------------------------------------------------
227             # _dbi_config_vars -- Gets the config variables from the dir_config and logs
228             # errors if required fields were not set, returns undef if any of the fields
229             # had errors or a hash of the values if they were all OK. Takes a request
230             # object.
231              
232             sub _dbi_config_vars($)
233             {
234             my( $r ) = @_;
235              
236             my %c; # config variables hash
237              
238             =head1 APACHE CONFIGURATION DIRECTIVES
239              
240              
241             All configuration directives for this module are passed in PerlSetVars. These
242             PerlSetVars must begin with the AuthName that you are describing, so if your
243             AuthName is PrivateBankingSystem they will look like:
244              
245             PerlSetVar PrivateBankingSystemLDAP_DN "o=bank.com"
246              
247             See also L for the directives required for any kind
248             of Apache::AuthCookie-based authentication system.
249              
250             In the following descriptions, replace "WhatEver" with your particular
251             AuthName. The available configuration directives are as follows:
252              
253             =over 4
254              
255             =item C
256              
257             Specifies the BaseDN for LDAP for the database you wish to connect to retrieve
258             user information. This is required and has no default value.
259              
260             =cut
261              
262             unless ( $c{ LDAP_DN } = _dir_config_var $r, 'LDAP_DN' ) {
263             _log_not_set $r, 'LDAP_DN';
264             return undef;
265             }
266              
267             =item C
268              
269             Specifies the user id in the database you wish to connect to retrieve
270             user information. This is required and has no default value.
271              
272             =cut
273              
274             unless ( $c{ LDAP_user } = _dir_config_var $r, 'LDAP_user' ) {
275             _log_not_set $r, 'LDAP_user';
276             return undef;
277             }
278              
279             =item C
280             The host to connect to. This is not required and defaults to localhost.
281              
282              
283             =cut
284              
285             $c{ LDAP_host } = _dir_config_var( $r, 'LDAP_host' )
286             || "localhost";
287              
288              
289              
290              
291             =item C
292             An extra filter for the search for the user. Is not required
293              
294              
295             =cut
296              
297             $c{ LDAP_filter } = _dir_config_var( $r, 'LDAP_filter') || "";
298              
299              
300              
301             =item C
302              
303             The file that contains the secret key (on the first line of the file). This
304             is required and has no default value. This key should be owned and only
305             readable by root. It is read at server startup time.
306             The key should be long and fairly random. If you want, you
307             can change it and restart the server, (maybe daily), which will invalidate
308             all prior-issued tickets.
309              
310             =cut
311              
312             unless (
313             $c{ LDAP_secretkeyfile } = _dir_config_var $r, 'LDAP_SecretKeyFile'
314             ) {
315             _log_not_set $r, 'LDAP_SecretKeyFile';
316             return undef;
317             }
318              
319             =item C
320              
321             What kind of encryption to use to prevent the user from looking at the fields
322             in the ticket we give them. This is almost completely useless, so don't
323             switch it on unless you really know you need it. It does not provide any
324             protection of the password in transport; use SSL for that. It can be 'none',
325             'des', 'idea', 'blowfish', or 'blowfish_pp'.
326              
327             This is not required and defaults to 'none'.
328              
329             =cut
330              
331             $c{ LDAP_encryptiontype } = _dir_config_var( $r, 'LDAP_EncryptionType' )
332             || 'none';
333             # If we used encryption we need to pull in Crypt::CBC.
334             if ( $c{ LDAP_encryptiontype } ne 'none' ) {
335             require Crypt::CBC;
336             }
337              
338             =item C
339              
340             How long tickets are good for after being issued. Note that presently
341             Apache::AuthCookie does not set a client-side expire time, which means that
342             most clients will only keep the cookie until the user quits the browser.
343             However, if you wish to force people to log in again sooner than that, set
344             this value. This can be 'forever' or a life time specified as:
345              
346             DD-hh-mm-ss -- Days, hours, minute and seconds to live.
347              
348             This is not required and defaults to '00-24-00-00' or 24 hours.
349              
350             =cut
351              
352             $c{ LDAP_sessionlifetime }
353             = _dir_config_var( $r, 'LDAP_SessionLifetime' ) || '00-24-00-00';
354              
355              
356              
357              
358              
359              
360             ## This is for some leftover DBI code:
361              
362             =item C
363              
364             Specifies the DSN for DBI for the database you wish to connect to retrieve
365             user information. This is required and has no default value.
366              
367             =cut
368              
369             unless ( $c{ DBI_DSN } = _dir_config_var $r, 'DBI_DSN' ) {
370             _log_not_set $r, 'DBI_DSN';
371             return undef;
372             }
373              
374             =item C
375              
376             The user to log into the database as. This is not required and
377             defaults to undef.
378              
379             =cut
380              
381             $c{ DBI_user } = _dir_config_var( $r, 'DBI_User')
382             || undef;
383              
384             =item C
385              
386             The password to use to access the database. This is not required
387             and defaults to undef.
388              
389             =cut
390              
391             $c{ DBI_password } = _dir_config_var( $r, 'DBI_Password' )
392             || undef;
393              
394              
395              
396             =item C
397              
398             The table that has the user / group information. This is not required and
399             defaults to 'groups'.
400              
401             =cut
402              
403             $c{ DBI_groupstable } = _dir_config_var( $r, 'DBI_GroupsTable')
404             || 'groups';
405              
406             =item C
407              
408             The field in the above table that has the group name. This is not required
409             and defaults to 'grp' (to prevent conflicts with the SQL reserved word
410             'group').
411              
412             =cut
413              
414             $c{ DBI_groupfield } = _dir_config_var( $r, 'DBI_GroupField')
415             || 'grp';
416              
417             =item C
418              
419             The field in the above table that has the user name. This is not required
420             and defaults to 'user'.
421              
422             =cut
423              
424             $c{ DBI_groupuserfield } = _dir_config_var( $r, 'DBI_GroupUserField' )
425             || 'user';
426              
427              
428              
429              
430              
431             return %c;
432             }
433              
434             #-------------------------------------------------------------------------------
435             # _now_year_month_day_hour_minute_second -- Return a string with the time in
436             # this order separated by dashes.
437              
438             sub _now_year_month_day_hour_minute_second()
439             {
440             return sprintf '%04d-%02d-%02d-%02d-%02d-%02d', Today_and_Now;
441             }
442              
443             #-------------------------------------------------------------------------------
444             # _percent_encode -- Percent-encode (like URI encoding) any non-alphanumberics
445             # in the supplied string.
446              
447             sub _percent_encode($)
448             {
449             my( $str ) = @_;
450             $str =~ s/([^\w])/ uc sprintf '%%%02x', ord $1 /eg;
451             return $str;
452             }
453              
454             #-------------------------------------------------------------------------------
455             # _percent_decode -- Percent-decode (like URI decoding) any %XX sequences in
456             # the supplied string.
457              
458             sub _percent_decode($)
459             {
460             my( $str ) = @_;
461             $str =~ s/%([0-9a-fA-F]{2})/ pack( "c",hex( $1 ) ) /ge;
462             return $str;
463             }
464              
465             #===============================================================================
466             # P U B L I C F U N C T I O N S
467             #===============================================================================
468              
469             #-------------------------------------------------------------------------------
470             # Take the credentials for a user and check that they match; if so, return
471             # a new session key for this user that can be stored in the cookie.
472             # If there is a problem, return a bogus session key.
473              
474             sub authen_cred($$\@)
475             {
476             my( $self, $r, @credentials ) = @_;
477              
478             my $auth_name = $r->auth_name;
479              
480             # Username goes in credential_0
481             my $user = $credentials[ 0 ];
482             unless ( $user =~ /^.+$/ ) {
483             $r->log_reason( "Apache::AuthCookieLDAP: no username supplied for auth realm $auth_name", $r->uri );
484             return 'bad';
485             }
486             # Password goes in credential_1
487             my $password = $credentials[ 1 ];
488             unless ( $password =~ /^.+$/ ) {
489             $r->log_reason( "Apache::AuthCookieLDAP: no password supplied for auth realm $auth_name", $r->uri );
490             return 'bad';
491             }
492              
493             # get the configuration information.
494             my %c = _dbi_config_vars $r;
495              
496              
497              
498              
499             # Connect to the host
500             my $con;
501             unless ($con = Net::LDAP->new($c{LDAP_host}))
502             {
503             $r->log_reason("LDAP Connection Failed", $r->uri);
504             return 'bad';
505             }
506            
507             # Bind annonymously
508              
509              
510             my $mess = $con->bind();
511             unless ($mess->code == LDAP_SUCCESS) {
512             $r->log_reason("LDAP Bind Failed", $r->uri);
513             return 'bad';
514             }
515              
516              
517             # Search for the user
518             my $filter = "($c{LDAP_user}=$user)";
519             if($c{LDAP_filter} ne "")
520             {
521             $filter = "(& $filter ($c{LDAP_filter}))";
522             }
523             $mess = $con->search(base => $c{LDAP_DN}, filter => $filter);
524             unless ($mess->code == LDAP_SUCCESS) {
525             $r->log_reason("LDAP Search Failed", $r->uri);
526             return 'bad';
527             }
528              
529              
530             # Does the user exsists
531             unless ($mess->count) {
532             $r->log_reason("User: $user does not excist", $r->uri);
533             return 'bad';
534             }
535            
536             # Take the first user
537             my $entry = $mess->first_entry;
538             my $dn = $entry->dn;
539              
540             # Bind as the user we're authenticating
541             $mess = $con->bind($dn, password => $password);
542             unless ($mess->code == LDAP_SUCCESS) {
543             $r->log_reason("User $user har wrong password", $r->uri);
544             return 'bad';
545             }
546             $con->unbind;
547              
548              
549              
550             # Create the expire time for the ticket.
551             my $expire_time;
552             # expire time in a zillion years if it's forever.
553             if ( lc $c{ LDAP_sessionlifetime } eq 'forever' ) {
554             $expire_time = '9999-01-01-01-01-01';
555             } else {
556             my( $deltaday, $deltahour, $deltaminute, $deltasecond )
557             = split /-/, $c{ LDAP_sessionlifetime };
558             # Figure out the expire time.
559             $expire_time = sprintf(
560             '%04d-%02d-%02d-%02d-%02d-%02d',
561             Add_Delta_DHMS( Today_and_Now,
562             $deltaday, $deltahour,
563             $deltaminute, $deltasecond )
564             );
565             }
566              
567             # Now we need to %-encode non-alphanumberics in the username so we
568             # can stick it in the cookie safely. *** DEBUG *** check this
569             my $enc_user = _percent_encode $user;
570              
571             # OK, now we stick the username and the current time and the expire
572             # time together to make the public part of the session key:
573             my $current_time = _now_year_month_day_hour_minute_second;
574             my $public_part = "$enc_user:$current_time:$expire_time";
575              
576             # Now we calculate the hash of this and the secret key and then
577             # calculate the hash of *that* and the secret key again.
578             my $secret_key = $SECRET_KEYS{ $auth_name };
579             unless ( defined $secret_key ) {
580             $r->log_reason( "Apache::AuthCookieLDAP: didn't have the secret key for auth realm $auth_name", $r->uri );
581             return 'bad';
582             }
583             my $hash = md5_hex( join ':', $secret_key, md5_hex(
584             join ':', $public_part, $secret_key
585             ) );
586              
587             # Now we add this hash to the end of the public part.
588             my $session_key = "$public_part:$hash";
589              
590             # Now we encrypt this and return it.
591             my $encrypted_session_key;
592             if ( $c{ LDAP_encryptiontype } eq 'none' ) {
593             $encrypted_session_key = $session_key;
594             } elsif ( lc $c{ LDAP_encryptiontype } eq 'des' ) {
595             $CIPHERS{ "des:$auth_name" }
596             ||= Crypt::CBC->new( $secret_key, 'DES' );
597             $encrypted_session_key = $CIPHERS{
598             "des:$auth_name"
599             }->encrypt_hex( $session_key );
600             } elsif ( lc $c{ LDAP_encryptiontype } eq 'idea' ) {
601             $CIPHERS{ "idea:$auth_name" }
602             ||= Crypt::CBC->new( $secret_key, 'IDEA' );
603             $encrypted_session_key = $CIPHERS{
604             "idea:$auth_name"
605             }->encrypt_hex( $session_key );
606             } elsif ( lc $c{ LDAP_encryptiontype } eq 'blowfish' ) {
607             $CIPHERS{ "blowfish:$auth_name" }
608             ||= Crypt::CBC->new( $secret_key, 'Blowfish' );
609             $encrypted_session_key = $CIPHERS{
610             "blowfish:$auth_name"
611             }->encrypt_hex( $session_key );
612             }
613              
614             return $encrypted_session_key;
615             }
616              
617             #-------------------------------------------------------------------------------
618             # Take a session key and check that it is still valid; if so, return the user.
619              
620             sub authen_ses_key($$$)
621             {
622             my( $self, $r, $encrypted_session_key ) = @_;
623              
624             my $auth_name = $r->auth_name;
625              
626             # Get the configuration information.
627             my %c = _dbi_config_vars $r;
628              
629             # Get the secret key.
630             my $secret_key = $SECRET_KEYS{ $auth_name };
631             unless ( defined $secret_key ) {
632             $r->log_reason( "Apache::AuthCookieLDAP: didn't the secret key from for auth realm $auth_name", $r->uri );
633             return undef;
634             }
635            
636             # Decrypt the session key.
637             my $session_key;
638             if ( $c{ LDAP_encryptiontype } eq 'none' ) {
639             $session_key = $encrypted_session_key;
640             } else {
641             # Check that this looks like an encrypted hex-encoded string.
642             unless ( $encrypted_session_key =~ /^[0-9a-fA-F]+$/ ) {
643             $r->log_reason( "Apache::AuthCookieLDAP: encrypted session key $encrypted_session_key doesn't look like it's properly hex-encoded for auth realm $auth_name", $r->uri );
644             return undef;
645             }
646              
647             # Get the cipher from the cache, or create a new one if the
648             # cached cipher hasn't been created, & decrypt the session key.
649             my $cipher;
650             if ( lc $c{ LDAP_encryptiontype } eq 'des' ) {
651             $cipher = $CIPHERS{ "des:$auth_name" }
652             ||= Crypt::CBC->new( $secret_key, 'DES' );
653             } elsif ( lc $c{ LDAP_encryptiontype } eq 'idea' ) {
654             $cipher = $CIPHERS{ "idea:$auth_name" }
655             ||= Crypt::CBC->new( $secret_key, 'IDEA' );
656             } elsif ( lc $c{ LDAP_encryptiontype } eq 'blowfish' ) {
657             $cipher = $CIPHERS{ "blowfish:$auth_name" }
658             ||= Crypt::CBC->new( $secret_key, 'Blowfish' );
659             } elsif ( lc $c{ LDAP_encryptiontype } eq 'blowfish_pp' ) {
660             $cipher = $CIPHERS{ "blowfish_pp:$auth_name" }
661             ||= Crypt::CBC->new( $secret_key, 'Blowfish_PP' );
662             } else {
663             $r->log_reason( "Apache::AuthCookieLDAP: unknown encryption type $c{ LDAP_encryptiontype } for auth realm $auth_name", $r->uri );
664             return undef;
665             }
666             $session_key = $cipher->decrypt_hex( $encrypted_session_key );
667             }
668            
669             # Break up the session key.
670             my( $enc_user, $issue_time, $expire_time, $supplied_hash )
671             = split /:/, $session_key;
672             # Let's check that we got passed sensible values in the cookie.
673             unless ( $enc_user =~ /^[a-zA-Z0-9_\%]+$/ ) {
674             $r->log_reason( "Apache::AuthCookieLDAP: bad percent-encoded user $enc_user recovered from session ticket for auth_realm $auth_name", $r->uri );
675             return undef;
676             }
677             # decode the user
678             my $user = _percent_decode $enc_user;
679             unless ( $issue_time =~ /^\d{4}-\d{2}-\d{2}-\d{2}-\d{2}-\d{2}$/ ) {
680             $r->log_reason( "Apache::AuthCookieLDAP: bad issue time $issue_time recovered from ticket for user $user for auth_realm $auth_name", $r->uri );
681             return undef;
682             }
683             unless ( $expire_time =~ /^\d{4}-\d{2}-\d{2}-\d{2}-\d{2}-\d{2}$/ ) {
684             $r->log_reason( "Apache::AuthCookieLDAP: bad expire time $expire_time recovered from ticket for user $user for auth_realm $auth_name", $r->uri );
685             return undef;
686             }
687             unless ( $supplied_hash =~ /^[0-9a-fA-F]{32}$/ ) {
688             $r->log_reason( "Apache::AuthCookieLDAP: bad hash $supplied_hash recovered from ticket for user $user for auth_realm $auth_name", $r->uri );
689             return undef;
690             }
691              
692             # Calculate the hash of the user, issue time, expire_time and
693             # the secret key and then the hash of that and the secret key again.
694             my $hash = md5_hex( join ':', $secret_key, md5_hex(
695             join ':', $enc_user, $issue_time, $expire_time, $secret_key
696             ) );
697              
698             # Compare it to the hash they gave us.
699             unless ( $hash eq $supplied_hash ) {
700             $r->log_reason( "Apache::AuthCookieLDAP: hash in cookie did not match calculated hash of contents for user $user for auth realm $auth_name", $r->uri );
701             return undef;
702             }
703              
704             # Check that their session hasn't timed out.
705             if ( _now_year_month_day_hour_minute_second gt $expire_time ) {
706             $r->log_reason( "Apache:AuthCookieLDAP: expire time $expire_time has passed for user $user for auth realm $auth_name", $r->uri );
707             return undef;
708             }
709              
710             # If we're being paranoid about timing-out long-lived sessions,
711             # check that the issue time + the current (server-set) session lifetime
712             # hasn't passed too (in case we issued long-lived session tickets
713             # in the past that we want to get rid of). *** DEBUG ***
714             # if ( lc $c{ DBI_AlwaysUseCurrentSessionLifetime } eq 'on' ) {
715              
716             # They must be okay, so return the user.
717             return $user;
718             }
719              
720             ###########################################################################
721             # This is taken from AuthCookieDBI and checks user groups from a database #
722             ###########################################################################
723              
724              
725              
726             sub group($$$)
727             {
728             my( $self, $r, $groups ) = @_;
729             my @groups = split(/\s+/, $groups);
730              
731             my $auth_name = $r->auth_name;
732              
733             # Get the configuration information.
734             my %c = _dbi_config_vars $r;
735              
736             my $user = $r->connection->user;
737              
738             # See if we have a row in the groups table for this user/group.
739             my $dbh = DBI->connect( $c{ DBI_DSN },
740             $c{ DBI_user }, $c{ DBI_password } );
741             unless ( defined $dbh ) {
742             $r->log_reason( "Apache::AuthCookieDBI: couldn't connect to $c{ DBI_DSN } for auth realm $auth_name", $r->uri );
743             return undef;
744             }
745              
746             # Now loop through all the groups to see if we're a member of any:
747             my $sth = $dbh->prepare( <<"EOS" );
748             SELECT $c{ DBI_groupuserfield }
749             FROM $c{ DBI_groupstable }
750             WHERE $c{ DBI_groupfield } = ?
751             AND $c{ DBI_groupuserfield } = ?
752             EOS
753             foreach my $group ( @groups ) {
754             $sth->execute( $group, $user );
755             return OK if ( $sth->fetchrow_array );
756             }
757             $r->log_reason( "Apache::AuthCookieDBI: user $user was not a member of any of the required groups @groups for auth realm $auth_name", $r->uri );
758             return FORBIDDEN;
759             }
760              
761              
762              
763              
764             1;
765             __END__