Apache-AuthCookieDBI
view release on metacpan or search on metacpan
AuthCookieDBI.pm view on Meta::CPAN
I suggest using DBI_SecretKey instead.
=cut
unless ( $c{DBI_secretkeyfile} = _dir_config_var $r, 'DBI_SecretKeyFile'
or _dir_config_var $r, 'DBI_SecretKey' )
{
_log_not_set $r, 'DBI_SecretKeyFile or DBI_SecretKey';
return;
}
=item C<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'.
=cut
$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;
}
=item C<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-24-00-00' or 24 hours.
=cut
$c{DBI_sessionlifetime} = _dir_config_var( $r, 'DBI_SessionLifetime' )
|| '00-24-00-00';
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
#===============================================================================
=head1 SUBCLASSING
You can subclass this module to override public functions and change
their behaviour.
=over 4
=item C<extra_session_info()>
This method returns extra fields to add to the session key.
It should return a string consisting of ":field1:field2:field3"
(where each field is preceded by a colon).
The default implementation returns false.
=back
=cut
sub extra_session_info {
my ( $self, $r, @credentials ) = @_;
return;
}
#-------------------------------------------------------------------------------
# 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 ( $user, $password, @extra_credentials ) = @credentials;
my $auth_name = $r->auth_name;
( $user, $password ) = _defined_or_empty( $user, $password );
if ( !length $user ) {
$r->log_reason(
"Apache::AuthCookieDBI: no username supplied for auth realm $auth_name",
$r->uri
);
return;
}
if ( !length $password ) {
$r->log_reason(
"Apache::AuthCookieDBI: no password supplied for auth realm $auth_name",
$r->uri
);
return;
}
AuthCookieDBI.pm view on Meta::CPAN
unless ( defined $crypted_password ) {
$r->log_reason(
"Apache::AuthCookieDBI: couldn't select password from $c{ DBI_DSN }, $c{ DBI_userstable }, $c{ DBI_userfield } for user $user for auth realm $auth_name",
$r->uri
);
return;
}
# now return unless the passwords match.
if ( lc $c{DBI_crypttype} eq 'none' ) {
unless ( $password eq $crypted_password ) {
$r->log_reason(
"Apache::AuthCookieDBI: plaintext passwords didn't match for user $user for auth realm $auth_name",
$r->uri
);
return;
}
}
elsif ( lc $c{DBI_crypttype} eq 'crypt' ) {
my $salt = substr $crypted_password, 0, 2;
unless ( crypt( $password, $salt ) eq $crypted_password ) {
$r->log_reason(
"Apache::AuthCookieDBI: crypted passwords didn't match for user $user for auth realm $auth_name",
$r->uri
);
return;
}
}
elsif ( lc $c{DBI_crypttype} eq 'md5' ) {
unless ( md5_hex($password) eq $crypted_password ) {
$r->log_reason(
"Apache::AuthCookieDBI: MD5 passwords didn't match for user $user for auth realm $auth_name",
$r->uri
);
return;
}
}
# 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";
$public_part .= $self->extra_session_info( $r, @credentials );
# 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::AuthCookieDBI: didn't have the secret key for auth realm $auth_name",
$r->uri
);
return;
}
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);
}
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;
AuthCookieDBI.pm view on Meta::CPAN
$r->uri
);
return;
}
# 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::AuthCookieDBI: encrypted session key $encrypted_session_key doesn't look like it's properly hex-encoded for auth realm $auth_name",
$r->uri
);
return;
}
# 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::AuthCookieDBI: unknown encryption type $c{ DBI_encryptiontype } for auth realm $auth_name",
$r->uri
);
return;
}
$session_key = $cipher->decrypt_hex($encrypted_session_key);
}
# Break up the session key.
my ( $enc_user, $issue_time, $expire_time, @rest ) =
( split /:/, $session_key );
my $supplied_hash = pop @rest;
( $enc_user, $issue_time, $expire_time, $supplied_hash ) =
_defined_or_empty( $enc_user, $issue_time, $expire_time, $supplied_hash );
# Let's check that we got passed sensible values in the cookie.
unless ( $enc_user =~ /^[a-zA-Z0-9_\%]+$/ ) {
$r->log_reason(
"Apache::AuthCookieDBI: bad percent-encoded user $enc_user recovered from session ticket for auth_realm $auth_name",
$r->uri
);
return;
}
# 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::AuthCookieDBI: bad issue time $issue_time recovered from ticket for user $user for auth_realm $auth_name",
$r->uri
);
return;
}
unless ( $expire_time =~ /^\d{4}-\d{2}-\d{2}-\d{2}-\d{2}-\d{2}$/ ) {
$r->log_reason(
"Apache::AuthCookieDBI: bad expire time $expire_time recovered from ticket for user $user for auth_realm $auth_name",
$r->uri
);
return;
}
unless ( $supplied_hash =~ /^[0-9a-fA-F]{32}$/ ) {
$r->log_reason(
"Apache::AuthCookieDBI: bad hash $supplied_hash recovered from ticket for user $user for auth_realm $auth_name",
$r->uri
);
return;
}
# 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, @rest, $secret_key
)
);
# Compare it to the hash they gave us.
unless ( $hash eq $supplied_hash ) {
$r->log_reason(
"Apache::AuthCookieDBI: hash in cookie did not match calculated hash of contents for user $user for auth realm $auth_name",
$r->uri
);
return;
}
# Check that their session hasn't timed out.
if ( _now_year_month_day_hour_minute_second gt $expire_time ) {
$r->log_reason(
"Apache:AuthCookieDBI: expire time $expire_time has passed for user $user for auth realm $auth_name",
$r->uri
);
return;
}
# 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). *** TODO ***
# if ( lc $c{ DBI_AlwaysUseCurrentSessionLifetime } eq 'on' ) {
# They must be okay, so return the user.
return $user;
}
( run in 1.805 second using v1.01-cache-2.11-cpan-5a3173703d6 )