CBC results from the CPAN

Apache-AuthCookieDBIRadius

view release on metacpan or search on metacpan

AuthCookieDBIRadius.pm view on Meta::CPAN

#===============================================================================
#
# Apache::AuthCookieDBIRadius
#
# An AuthCookie module backed by a DBI database, then to a Radius server.
#
# Copyright (C) 1999 SF Interactive, Inc.  All rights reserved.
#
# Author:  Charles Day <chaday@s1te.com>
# Original Author:  Jacob Davies <jacob@sfinteractive.com> <jacob@well.com>
#
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Lesser General Public
# License as published by the Free Software Foundation; either
# version 2.1 of the License, or (at your option) any later version.
# 
# This library is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
# Lesser General Public License for more details.
# 
# You should have received a copy of the GNU Lesser General Public
# License along with this library; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
#
# $Id: AuthCookieDBIRadius.pm,v 1.19 2001/11/14 12:07:01 barracode Exp $
#
#===============================================================================

package Apache::AuthCookieDBIRadius;

use strict;
use 5.004;
use vars qw( $VERSION );

# $Id: AuthCookieDBIRadius.pm,v 1.19 2001/11/14 12:07:01 barracode Exp $
$VERSION = '1.19';

use Apache::AuthCookie;
use vars qw( @ISA );
@ISA = qw( Apache::AuthCookie );

use Apache;
use Apache::DBI;
use Apache::Constants;
use Apache::File;
use Digest::MD5 qw( md5_hex );
use Date::Calc qw( Today_and_Now Add_Delta_DHMS );
# Also uses Crypt::CBC if you're using encrypted cookies.

# Added IPC::ShareLite.
use IPC::ShareLite qw( LOCK_EX LOCK_SH LOCK_UN LOCK_NB );

# Added Radius.
use Authen::Radius;
use Tie::IxHash;


#===============================================================================
# F U N C T I O N   D E C L A R A T I O N S
#===============================================================================

sub _log_not_set($$);
sub _dir_config_var($$);
sub _dbi_config_vars($);
sub _now_year_month_day_hour_minute_second();
sub _percent_encode($);
sub _percent_decode($);

sub authen_cred($$\@);
sub authen_ses_key($$$);
sub group($$\@);

#===============================================================================
# P A C K A G E   G L O B A L S
#===============================================================================

use vars qw( %CIPHERS );
# Stores Cipher::CBC objects in $CIPHERS{ idea:AuthName },
# $CIPHERS{ des:AuthName } etc.

use vars qw( %SECRET_KEYS );
# Stores secret keys for MD5 checksums and encryption for each auth realm in
# $SECRET_KEYS{ AuthName }.

#===============================================================================
# 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
#===============================================================================

BEGIN {
   my @keyfile_vars = grep {
      $_ =~ /DBI_SecretKeyFile$/
   } keys %{ Apache->server->dir_config() };
   foreach my $keyfile_var ( @keyfile_vars ) {
      my $keyfile = Apache->server->dir_config( $keyfile_var );
      my $auth_name = $keyfile_var;
      $auth_name =~ s/DBI_SecretKeyFile$//;
      unless ( open( KEY, "<$keyfile" ) ) {
         Apache::log_error( "Could not open keyfile for $auth_name in file $keyfile" );
      } else {
         $SECRET_KEYS{ $auth_name } = <KEY>;
         close KEY;
      }
   }
}

#===============================================================================
# P R I V A T E   F U N C T I O N S
#===============================================================================

#-------------------------------------------------------------------------------
# _log_not_set -- Log that a particular authentication variable was not set.

sub _log_not_set($$)
{
	my( $r, $variable ) = @_;
	my $auth_name = $r->auth_name;
	$r->log_error( "Apache::AuthCookieDBIRadius: $variable not set for auth realm
$auth_name", $r->uri );
}

#-------------------------------------------------------------------------------
# _dir_config_var -- Get a particular authentication variable.

sub _dir_config_var($$)
{
	my( $r, $variable ) = @_;
	my $auth_name = $r->auth_name;
	return $r->dir_config( "$auth_name$variable" );
}

#-------------------------------------------------------------------------------
# _dbi_config_vars -- Gets the config variables from the dir_config and logs
# errors if required fields were not set, returns undef if any of the fields
# had errors or a hash of the values if they were all OK.  Takes a request
# object.

sub _dbi_config_vars($)
{

AuthCookieDBIRadius.pm view on Meta::CPAN

	#<WhatEverDBI_UserField>
	#The field in the above table that has the user name.  This is not
	#required and defaults to 'user'.

	$c{ DBI_userfield } = _dir_config_var( $r, 'DBI_UserField' ) || 'user';

	#<WhatEverDBI_PasswordField>
	#The field in the above table that has the password.  This is not
	#required and defaults to 'password'.

	$c{ DBI_passwordfield } = _dir_config_var( $r, 'DBI_PasswordField' ) || 'password';

	#<WhatEverDBI_CryptType>
	#What kind of hashing is used on the password field in the database.  This can
	#be 'none', 'crypt', or 'md5'.  This is not required and defaults to 'none'.

	$c{ DBI_crypttype } = _dir_config_var( $r, 'DBI_CryptType' ) || 'crypt';

	#<WhatEverDBI_GroupsTable>
	#The table that has the user / group information.  This is not required and
	#defaults to 'groups'.

	$c{ DBI_groupstable } = _dir_config_var( $r, 'DBI_GroupsTable' ) || 'groups';

	#<WhatEverDBI_GroupField>
	#The field in the above table that has the group name.  This is not required
	#and defaults to 'grp' (to prevent conflicts with the SQL reserved word 'group').

	$c{ DBI_groupfield } = _dir_config_var( $r, 'DBI_GroupField' ) || 'grp';

	#<WhatEverDBI_GroupUserField>
	#The field in the above table that has the user name.  This is not required
	#and defaults to 'user'.

	$c{ DBI_groupuserfield } = _dir_config_var( $r, 'DBI_GroupUserField' ) || 'user';

	#<WhatEverDBI_SecretKeyFile>
	#The file that contains the secret key (on the first line of the file).  This
	#is required and has no default value.  This key should be owned and only
	#readable by root.  It is read at server startup time.
	#The key should be long and fairly random.  If you want, you
	#can change it and restart the server, (maybe daily), which will invalidate
	#all prior-issued tickets.

	unless ( $c{ DBI_secretkeyfile } = _dir_config_var $r, 'DBI_SecretKeyFile' )
	{
		_log_not_set $r, 'DBI_SecretKeyFile';
		return undef;
	}

	#<WhatEverDBI_EncryptionType>
	#What kind of encryption to use to prevent the user from looking at the fields
	#in the ticket we give them.  This is almost completely useless, so don't
	#switch it on unless you really know you need it.  It does not provide any
	#protection of the password in transport; use SSL for that.  It can be 'none',
	#'des', 'idea', 'blowfish', or 'blowfish_pp'.
	#This is not required and defaults to 'none'.'

	$c{ DBI_encryptiontype } = _dir_config_var( $r, 'DBI_EncryptionType' ) || 'none';

	# If we used encryption we need to pull in Crypt::CBC.
	if ( $c{ DBI_encryptiontype } ne 'none' ) 
	{
		require Crypt::CBC;
	}

	#<WhatEverDBI_SessionLifetime>
	#How long tickets are good for after being issued.  Note that presently
	#Apache::AuthCookie does not set a client-side expire time, which means that
	#most clients will only keep the cookie until the user quits the browser.
	#However, if you wish to force people to log in again sooner than that, set
	#this value.  This can be 'forever' or a life time specified as:
	#DD-hh-mm-ss -- Days, hours, minute and seconds to live.
	#This is not required and defaults to '00-12-00-00' or 12 hours.
	$c{ DBI_sessionlifetime } = _dir_config_var( $r, 'DBI_SessionLifetime' ) || '00-12-00-00';

	# Custom variables from httpd.conf.
	$c{ DBI_a }    			  = _dir_config_var( $r, 'DBI_a' ) || 'off';
	$c{ DBI_b }     			  = _dir_config_var( $r, 'DBI_b' ) || 'off';
 	$c{ DBI_c }    			  = _dir_config_var( $r, 'DBI_c' ) || 'off';
 	$c{ DBI_d }    			  = _dir_config_var( $r, 'DBI_d' ) || 'off';
 	$c{ DBI_e }    			  = _dir_config_var( $r, 'DBI_e' ) || 'off';
 	$c{ DBI_f }    			  = _dir_config_var( $r, 'DBI_f' ) || 'off';
 	$c{ DBI_g }    			  = _dir_config_var( $r, 'DBI_g' ) || 'off';

	# other fields from httpd.conf.	
	$c{ DBI_activeuser }      = _dir_config_var( $r, 'DBI_activeuser' ) || 'on';
   $c{ DBI_log_field } 	  	  = _dir_config_var( $r, 'DBI_log_field' ) || 'last_access';

	# Radius variables.
   #$c{ DBI_Radius_host }     = _dir_config_var( $r, 'DBI_Radius_host' ) || 'none';
   #$c{ DBI_Radius_port } 	  = _dir_config_var( $r, 'DBI_Radius_port' ) || '1645';
   #$c{ DBI_Radius_secret }   = _dir_config_var( $r, 'DBI_Radius_secret' ) || 'none';
   #$c{ DBI_Radius_timeout }  = _dir_config_var( $r, 'DBI_Radius_timeout' ) || 45;

	return %c;
}

#-------------------------------------------------------------------------------
# _now_year_month_day_hour_minute_second -- Return a string with the time in
# this order separated by dashes.

sub _now_year_month_day_hour_minute_second()
{
	return sprintf '%04d-%02d-%02d-%02d-%02d-%02d', Today_and_Now;
}

#-------------------------------------------------------------------------------
# _percent_encode -- Percent-encode (like URI encoding) any non-alphanumberics
# in the supplied string.

sub _percent_encode($)
{
	my( $str ) = @_;
	$str =~ s/([^\w])/ uc sprintf '%%%02x', ord $1 /eg;
	return $str;
}

#-------------------------------------------------------------------------------
# _percent_decode -- Percent-decode (like URI decoding) any %XX sequences in
# the supplied string.

sub _percent_decode($)
{

AuthCookieDBIRadius.pm view on Meta::CPAN

				return 'ERROR! Password did not match.';
				#return 'bad';
			}
		}
	}

	# Create the expire time for the ticket.
	my $expire_time;
	# expire time in a zillion years if it's forever.
	if ( lc $c{ DBI_sessionlifetime } eq 'forever' ) {
		$expire_time = '9999-01-01-01-01-01';
	} else {
		my( $deltaday, $deltahour, $deltaminute, $deltasecond )
		   = split /-/, $c{ DBI_sessionlifetime };
		# Figure out the expire time.
		$expire_time = sprintf(
			'%04d-%02d-%02d-%02d-%02d-%02d',
			Add_Delta_DHMS( Today_and_Now,
			                $deltaday, $deltahour,
					$deltaminute, $deltasecond )
		);
	}

	# Now we need to %-encode non-alphanumberics in the username so we
	# can stick it in the cookie safely. 
	my $enc_user = _percent_encode $user;

	# OK, now we stick the username and the current time and the expire
	# time together to make the public part of the session key:
	my $current_time = _now_year_month_day_hour_minute_second;

	#my $public_part = "$enc_user:$current_time:$expire_time";
   my $public_part = "$enc_user:$current_time:$expire_time:$activeuser:$a:$b:$c:$d:$e:$f:$g";

	# Now we calculate the hash of this and the secret key and then
	# calculate the hash of *that* and the secret key again.
	my $secret_key = $SECRET_KEYS{ $auth_name };

	unless ( defined $secret_key ) 
	{
		$r->log_reason( "Apache::AuthCookieDBIRadius: didn't have the secret key for auth realm $auth_name", $r->uri );
		return 'ERROR! Internal Server Error (333).  Please contact us immediately so we can fix this problem.';
		#return 'bad';
	}
	my $hash = md5_hex( join ':', $secret_key, md5_hex(
		join ':', $public_part, $secret_key
	) );

	# Now we add this hash to the end of the public part.
	my $session_key = "$public_part:$hash";

	# Now we encrypt this and return it.
	my $encrypted_session_key;
	if ( $c{ DBI_encryptiontype } eq 'none' ) 
	{
		$encrypted_session_key = $session_key;
	} 
	elsif ( lc $c{ DBI_encryptiontype } eq 'des' ) 
	{
		$CIPHERS{ "des:$auth_name"      }
		   ||= Crypt::CBC->new( $secret_key, 'DES' );
		$encrypted_session_key = $CIPHERS{
			"des:$auth_name"
		}->encrypt_hex( $session_key );
	} 
	elsif ( lc $c{ DBI_encryptiontype } eq 'idea' ) 
	{
		$CIPHERS{ "idea:$auth_name"      }
		   ||= Crypt::CBC->new( $secret_key, 'IDEA'     );
		$encrypted_session_key = $CIPHERS{
			"idea:$auth_name"
		}->encrypt_hex( $session_key );
	} 
	elsif ( lc $c{ DBI_encryptiontype } eq 'blowfish' ) 
	{
		$CIPHERS{ "blowfish:$auth_name" }
		   ||= Crypt::CBC->new( $secret_key, 'Blowfish' );
		$encrypted_session_key = $CIPHERS{
			"blowfish:$auth_name"
		}->encrypt_hex( $session_key );
	}

	# update log_field field.
   if ($c{ DBI_log_field })
   {
	   my $cmd = "UPDATE $c{DBI_userstable} SET $c{DBI_log_field} = 'NOW' WHERE $c{DBI_userfield} = \'$user\';";

      unless ($dbh->do($cmd))
      {
         $r->log_reason("Apache::AuthCookieDBIRadius: can not update $c{DBI_log_field}: $DBI::errstr: cmd=$cmd", $r->uri);
         $dbh->disconnect;
         return SERVER_ERROR;
      }
      $dbh->disconnect;
   }

	return $encrypted_session_key;
}


# Take a session key and check that it is still valid; if so, return the user.
sub authen_ses_key($$$)
{
	my( $self, $r, $encrypted_session_key ) = @_;

	my $auth_name = $r->auth_name;

	# Get the configuration information.
	my %c = _dbi_config_vars $r;

	# Get the secret key.
	my $secret_key = $SECRET_KEYS{ $auth_name };

	unless ( defined $secret_key ) {
		$r->log_reason( "Apache::AuthCookieDBIRadius: didn't the secret key from for auth realm $auth_name", $r->uri );
		return undef;
	}
	
	# Decrypt the session key.
	my $session_key;
	if ( $c{ DBI_encryptiontype } eq 'none' ) 
	{
		$session_key = $encrypted_session_key;
	} 
	else 
	{
		# Check that this looks like an encrypted hex-encoded string.
		unless ( $encrypted_session_key =~ /^[0-9a-fA-F]+$/ ) 
		{
			$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 );
			return undef;
		}

		# Get the cipher from the cache, or create a new one if the
		# cached cipher hasn't been created, & decrypt the session key.
		my $cipher;
		if ( lc $c{ DBI_encryptiontype } eq 'des' ) {
			$cipher = $CIPHERS{ "des:$auth_name" }
			   ||= Crypt::CBC->new( $secret_key, 'DES' );
		} elsif ( lc $c{ DBI_encryptiontype } eq 'idea' ) {
			$cipher = $CIPHERS{ "idea:$auth_name" }
			   ||= Crypt::CBC->new( $secret_key, 'IDEA' );
		} elsif ( lc $c{ DBI_encryptiontype } eq 'blowfish' ) {
			$cipher = $CIPHERS{ "blowfish:$auth_name" }
			   ||= Crypt::CBC->new( $secret_key, 'Blowfish' );
		} elsif ( lc $c{ DBI_encryptiontype } eq 'blowfish_pp' ) {
			$cipher = $CIPHERS{ "blowfish_pp:$auth_name" }
			   ||= Crypt::CBC->new( $secret_key, 'Blowfish_PP' );
		} else {
			$r->log_reason( "Apache::AuthCookieDBIRadius: unknown encryption type $c{ DBI_encryptiontype } for auth realm $auth_name", $r->uri );
			return undef;
		}
		$session_key = $cipher->decrypt_hex( $encrypted_session_key );
	}
	
	# Break up the session key.
   my( $enc_user,$issue_time,$expire_time,$activeuser,$a,$b,$c,$d,$e,$f,$g,$supplied_hash )
	   = split /:/, $session_key;
	# Let's check that we got passed sensible values in the cookie.
	unless ( $enc_user =~ /^[a-zA-Z0-9_\%]+$/ ) 
	{
		$r->log_reason( "Apache::AuthCookieDBIRadius: bad percent-encoded user $enc_user recovered from session ticket for auth_realm $auth_name", $r->uri );
		return undef;
	}

	# decode the user
	my $user = _percent_decode $enc_user;
	unless ( $issue_time =~ /^\d{4}-\d{2}-\d{2}-\d{2}-\d{2}-\d{2}$/ ) 
	{
		$r->log_reason( "Apache::AuthCookieDBIRadius: bad issue time $issue_time recovered from ticket for user $user for auth_realm $auth_name", $r->uri );
		return undef;
	}
	unless ( $expire_time =~ /^\d{4}-\d{2}-\d{2}-\d{2}-\d{2}-\d{2}$/ ) 
	{
		$r->log_reason( "Apache::AuthCookieDBIRadius: bad expire time $expire_time recovered from ticket for user $user for auth_realm $auth_name", $r->uri );
		return undef;
	}
	unless ( $supplied_hash =~ /^[0-9a-fA-F]{32}$/ ) 
	{
		$r->log_reason( "Apache::AuthCookieDBIRadius: bad hash $supplied_hash recovered from ticket for user $user for auth_realm $auth_name", $r->uri );
		return undef;
	}

	# Calculate the hash of the user, issue time, expire_time and
	# the secret key and then the hash of that and the secret key again.
	my $hash = md5_hex( join ':', $secret_key, md5_hex(
      join ':', $enc_user,$issue_time,$expire_time,$activeuser,$a,$b,$c,$d,$e,$f,$g,$secret_key
	) );

	# Compare it to the hash they gave us.
	unless ( $hash eq $supplied_hash ) {
		$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 );
		return undef;
	}

	# Check that their session hasn't timed out.
	if ( _now_year_month_day_hour_minute_second gt $expire_time ) 
	{
		$r->log_reason( "Apache:AuthCookieDBIRadius: expire time $expire_time has passed for user $user for auth realm $auth_name", $r->uri );
		return undef;
	}

	# If we're being paranoid about timing-out long-lived sessions,
	# check that the issue time + the current (server-set) session lifetime
	# hasn't passed too (in case we issued long-lived session tickets
	# in the past that we want to get rid of). *** DEBUG ***
	# if ( lc $c{ DBI_AlwaysUseCurrentSessionLifetime } eq 'on' ) {

( run in 0.446 second using v1.01-cache-2.11-cpan-df04353d9ac )