view release on metacpan or  search on metacpan

AuthCookieDBIRadius.pm  view on Meta::CPAN

	$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($)
{
	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 );
	   return 'ERROR! No Username Supplied';
		#return 'bad';
	}
	# Password goes in credential_1
	my $password = $credentials[ 1 ];

	# create $temp for error messages.
	my $temp = $password;
    
	unless ( $password =~ /^.+$/ ) 
	{
		$r->log_reason( "Apache::AuthCookieDBIRadius: no password supplied for auth realm $auth_name", $r->uri );
	   return 'ERROR! No Password Supplied';
		#return 'bad';
	}

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

  	# Lock out after 5 failed consecutive attempts. Unlock when the next IP comes in.
   my $attempts = 1;
   my @split = ();
   my $share = new IPC::ShareLite(  -key     => 'AuthCookie',
                                    -create  => 'yes',
                                    -destroy => 'no',
                                    -size    => 25 );

   # Retrieve value from memory.
   my $result = $share->fetch;
   if ($result =~ $ENV{REMOTE_ADDR})
   {
      @split = split(/\:/,$result);
      $attempts = $split[1]+1;
      if ($split[1] > 5)
      {
         $r->log_reason( "Apache::AuthCookieDBIRadius: Security Error!  Too many attempts to auth realm $auth_name", $r->uri );
         return "ERROR! Security error.  Too many attempts.";
      }
   }
   # Store new value.
   $result = $share->store("$ENV{REMOTE_ADDR}:$attempts");

	# Look up user in database.
	my $dbh = DBI->connect( $c{ DBI_DSN },
	                        $c{ DBI_user }, $c{ DBI_password } );
	unless ( defined $dbh ) 
	{
		$r->log_reason( "Apache::AuthCookieDBIRadius: couldn't connect to $c{ DBI_DSN } for auth realm $auth_name", $r->uri );
		return 'ERROR! Internal Server Error (111).  Please contact us immediately so we can fix this problem.';
		#return 'bad';
	}
	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) ]}";

	$result = $dbh->prepare($cmd);
	$result->execute;

	my @row = $result->fetchrow_array;

	# debug line.
	#$r->log_reason( "Apache::AuthCookieDBIRadius:  results from database query: row = @row for user $user for auth realm $auth_name", $r->uri );

	my $crypted_password = $row[0];
	my $activeuser = $row[1];
	my $a = $row[2];
	my $b = $row[3];