Apache-AuthCookieDBIRadius

 view release on metacpan or  search on metacpan

AuthCookie.pm  view on Meta::CPAN

    $r->headers_in->unset('Content-Length');
  }
  unless ($r->dir_config("${auth_name}Cache")) {
    $r->no_cache(1);
    $r->err_header_out("Pragma" => "no-cache");
  }
  $r->header_out("Location" => $args{'destination'});
  return REDIRECT;
}

sub logout($$) {
  my ($self,$r) = @_;
  my $debug = $r->dir_config("AuthCookieDebug") || 0;
  
  my ($auth_type, $auth_name) = ($r->auth_type, $r->auth_name);
  
  # Send the Set-Cookie header to expire the auth cookie.
  my $str = $self->cookie_string( request => $r,
											 key     => "$auth_type\_$auth_name",
								          value 	=> '',
											 expires => 'Mon, 21-May-1971 00:00:00 GMT' );

AuthCookieDBIRadius.pm  view on Meta::CPAN

# 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 );

AuthCookieDBIRadius.pm  view on Meta::CPAN

   }
}

#===============================================================================
# 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($)
{
	my( $r ) = @_;

	my %c; # config variables hash

	#<WhatEverDBI_DSN>
	#Specifies the DSN for DBI for the database you wish to connect to retrieve
	#user information.  This is required and has no default value.

	unless ( $c{ DBI_DSN } = _dir_config_var $r, 'DBI_DSN' ) 

AuthCookieDBIRadius.pm  view on Meta::CPAN

   #$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($)
{
	my( $str ) = @_;
	$str =~ s/%([0-9a-fA-F]{2})/ pack( "c",hex( $1 ) ) /ge;
	return $str;
}

#===============================================================================
# P U B L I C   F U N C T I O N S
#===============================================================================

#-------------------------------------------------------------------------------
# Take the credentials for a user and check that they match; if so, return
# a new session key for this user that can be stored in the cookie.
# If there is a problem, return a bogus session key.

sub authen_cred($$\@)
{
	my( $self, $r, @credentials ) = @_;

	my $auth_name = $r->auth_name;

	# Username goes in credential_0
	my $user = $credentials[ 0 ];
	unless ( $user =~ /^.+$/ ) 
	{
		$r->log_reason( "Apache::AuthCookieDBIRadius: no username supplied for auth realm $auth_name", $r->uri );

AuthCookieDBIRadius.pm  view on Meta::CPAN

         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 };

AuthCookieDBIRadius.pm  view on Meta::CPAN

	# They must be okay, so return the user.
	$r->subprocess_env('TICKET', $user);

	return $user;
}

#-------------------------------------------------------------------------------
# Take a list of groups and make sure that the current remote user is a member
# of one of them.

sub group($$\@)
{
	my( $self, $r, @groups ) = @_;

	my $auth_name = $r->auth_name;

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

	my $user = $r->connection->user;