Apache2-AuthCookieDBImg
view release on metacpan or search on metacpan
lib/Apache2/AuthCookieDBImg.pm view on Meta::CPAN
my image coding and hidden field coding into my HTML page selecting
a random image + key from the images table. For example, the output
from my perl randomizer spits out:
<img src="/images/dbimg/junk.png"><input type="hidden" name="credential_3" value="1">
To make the work of the randomizer easier I create my images table
like this:
create table images ( imagekey serial, imageurl char(128), imageword char(20));
And load it up like this:
inssert into images (imageurl,imageword) values ('/images/dbimg/junk.png','saywhat?');
Then create an image named junk.png and put it in my web server /images/dbimg folder.
The text on the image has a background picture plus the word "saywhat?" across the front.
The randomizer just looks up the imageurl and imagekey in the database and spits out
the appropriate HTML code. ApacheCookieDBImg then does a reverse operation, looking
up the imageword based on the key.
=head1 CAVEATS
This is not a truly random image, so it is not overly secure. The initial idea is just
to thwart stupid bots. Someone could easily visit the site and build a map of image
sources and the matching words. i.e. when credential_3 == 1 the word is always "saywhat?".
Not fool-proof, just and extra level of bot protection.
=cut
#===============================================================================
#===============================================================================
package Apache2::AuthCookieDBImg;
use strict;
use 5.004;
use vars qw( $VERSION );
$VERSION = '2.2';
use Apache2::AuthCookie;
use vars qw( @ISA );
@ISA = qw( Apache2::AuthCookie );
use Apache2::RequestRec;
use Apache::DBI;
use Apache2::Const -compile => qw( OK HTTP_FORBIDDEN );
use Apache2::ServerUtil;
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.
# Also uses Apache2::Session if you're using sessions.
#===============================================================================
# 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 extra_session_info($$\@);
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.
our @Extra_Data; # CSA Patch - needed for keeping cookie active
#===============================================================================
# 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( "Apache2::AuthCookieDBImg: $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.
=head1 APACHE CONFIGURATION DIRECTIVES
All configuration directives for this module are passed in PerlSetVars. These
PerlSetVars must begin with the AuthName that you are describing, so if your
AuthName is PrivateBankingSystem they will look like:
PerlSetVar PrivateBankingSystemDBI_DSN "DBI:mysql:database=banking"
See also L<Apache2::Authcookie> for the directives required for any kind
of Apache2::AuthCookie-based authentication system.
In the following descriptions, replace "WhatEver" with your particular
AuthName. The available configuration directives are as follows:
=over 4
lib/Apache2/AuthCookieDBImg.pm view on Meta::CPAN
=item C<WhatEverDBI_SessionActiveReset>
Force the session cookie expiration to reset whenever user activity is
detected (new page loaded, etc.). This allows a low expiration time (5 minutes)
that logs off when a session is inactive. Active sessions will be granted
more time each time they perform an action.
This is not required and defaults to 0 (Expire X minutes after initial logon).
=cut
sub _dbi_config_vars($) {
my( $r ) = @_;
my %c; # config variables hash
unless ( $c{ DBI_DSN } = _dir_config_var $r, 'DBI_DSN' ) {
_log_not_set $r, 'DBI_DSN';
return undef;
}
unless ( $c{ DBI_secretkey } = _dir_config_var $r, 'DBI_SecretKey' ) {
_log_not_set $r, 'DBI_SecretKey';
return undef;
}
$c{ DBI_user } = _dir_config_var( $r, 'DBI_User' ) || undef;
$c{ DBI_password } = _dir_config_var( $r, 'DBI_Password' ) || undef;
$c{ DBI_userstable } = _dir_config_var( $r, 'DBI_UsersTable' ) || 'users';
$c{ DBI_userfield } = _dir_config_var( $r, 'DBI_UserField' ) || 'user';
$c{ DBI_passwordfield } = _dir_config_var( $r, 'DBI_PasswordField' ) || 'password';
$c{ DBI_crypttype } = _dir_config_var( $r, 'DBI_CryptType' ) || 'none';
$c{ DBI_groupstable } = _dir_config_var( $r, 'DBI_GroupsTable' ) || 'groups';
$c{ DBI_groupfield } = _dir_config_var( $r, 'DBI_GroupField' ) || 'grp';
$c{ DBI_groupuserfield } = _dir_config_var( $r, 'DBI_GroupUserField' ) || 'user';
$c{ DBI_imgtable } = _dir_config_var( $r, 'DBI_ImgTable' ) || '';
$c{ DBI_imgkeyfield } = _dir_config_var( $r, 'DBI_ImgKeyField' ) || '';
$c{ DBI_imgwordfield } = _dir_config_var( $r, 'DBI_ImgWordField' ) || '';
$c{ DBI_encryptiontype } = _dir_config_var( $r, 'DBI_EncryptionType' ) || 'none';
$c{ DBI_sessionlifetime} = _dir_config_var( $r, 'DBI_SessionLifetime') || '00-24-00-00';
$c{ DBI_sessionmodule } = _dir_config_var( $r, 'DBI_SessionModule' );
$c{ DBI_SessionActiveReset } = _dir_config_var( $r, 'DBI_SessionActiveReset' ) || 0;
return %c;
# If we used encryption we need to pull in Crypt::CBC.
require Crypt::CBC if ( $c{ DBI_encryptiontype } ne 'none' );
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 does nothing.
=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 $auth_name = $r->auth_name;
# Username goes in credential_0
my $user = shift @credentials;
unless ( $user =~ /^.+$/ ) {
$r->log_error( "Apache2::AuthCookieDBI: no username supplied for auth realm $auth_name", $r->uri );
return undef;
}
# Password goes in credential_1
my $password = shift @credentials;
unless ( $password =~ /^.+$/ ) {
$r->log_error( "Apache2::AuthCookieDBI: no password supplied for auth realm $auth_name", $r->uri );
return undef;
}
# CSA Patch - Use global var
# needed later for authen_sess_key
lib/Apache2/AuthCookieDBImg.pm view on Meta::CPAN
sub authen_ses_key($$$)
{
my( $self, $r, $encrypted_session_key ) = @_;
my $auth_name = $r->auth_name;
# Enable Debugging In Here
my $debug = $r->dir_config("AuthCookieDebug") || 0;
# Get the configuration information.
my %c = _dbi_config_vars $r;
# Get the secret key.
my $secretkey = $c{ DBI_secretkey };
unless ( defined $secretkey ) {
$r->log_error( "Apache2::AuthCookieDBImg: didn't have 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_error( "Apache2::AuthCookieDBImg: 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( $secretkey, 'DES' );
} elsif ( lc $c{ DBI_encryptiontype } eq 'idea' ) {
$cipher = $CIPHERS{ "idea:$auth_name" }
||= Crypt::CBC->new( $secretkey, 'IDEA' );
} elsif ( lc $c{ DBI_encryptiontype } eq 'blowfish' ) {
$cipher = $CIPHERS{ "blowfish:$auth_name" }
||= Crypt::CBC->new( $secretkey, 'Blowfish' );
} elsif ( lc $c{ DBI_encryptiontype } eq 'blowfish_pp' ) {
$cipher = $CIPHERS{ "blowfish_pp:$auth_name" }
||= Crypt::CBC->new( $secretkey, 'Blowfish_PP' );
} else {
$r->log_error( "Apache2::AuthCookieDBImg: 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, $session_id,
$supplied_hash, @rest ) = split /:/, $session_key;
# Let's check that we got passed sensible values in the cookie.
unless ( $enc_user =~ /^[a-zA-Z0-9_\%]+$/ ) {
$r->log_error( "Apache2::AuthCookieDBImg: 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_error( "Apache2::AuthCookieDBImg: 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_error( "Apache2::AuthCookieDBImg: 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_error( "Apache2::AuthCookieDBImg: bad hash $supplied_hash recovered from ticket for user $user for auth_realm $auth_name", $r->uri );
return undef;
}
# If we're using a session module, check that their session exist.
if ( defined $c{ DBI_sessionmodule } ) {
my %session;
my $dbh = DBI->connect( $c{ DBI_DSN },
$c{ DBI_user }, $c{ DBI_password } );
unless ( defined $dbh ) {
$r->log_error( "Apache2::AuthCookieDBImg: couldn't connect to $c{ DBI_DSN } for auth realm $auth_name", $r->uri );
return undef;
}
eval {
tie %session, $c{ DBI_sessionmodule }, $session_id, +{
Handle => $dbh,
LockHandle => $dbh,
};
};
if ( $@ ) {
$r->log_error( "Apache2::AuthCookieDBImg: failed to tie session hash using session id $session_id for user $user for auth_realm $auth_name, error was $@", $r->uri );
return undef;
}
# Update a timestamp at the top level to make sure we sync.
$session{ timestamp } = _now_year_month_day_hour_minute_second;
$r->pnotes( $auth_name, \%session );
}
# Calculate the hash of the user, issue time, expire_time and
# the secret key and the session_id and then the hash of that
# and the secret key again.
my $hash = md5_hex( join ':', $secretkey, md5_hex( join ':',
$enc_user, $issue_time, $expire_time, $session_id, @rest, $secretkey
) );
# Compare it to the hash they gave us.
unless ( $hash eq $supplied_hash ) {
$r->log_error( "Apache2::AuthCookieDBImg: 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_error( "Apache:AuthCookieDBImg: 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). *** TODO ***
# if ( lc $c{ DBI_AlwaysUseCurrentSessionLifetime } eq 'on' ) {
# Expire Time Update (Inactivity Timer vs. Hard Time)
# If SessionActiveReset Flag Is On
#
if ($c{ DBI_SessionActiveReset}) {
my $ses_key = $self->gen_key($r, $user, \@Extra_Data);
$self->send_cookie($r, $ses_key);
$r->server->warn('Apache2:AuthCookieDBI: extended() '.$ses_key) if $debug >= 3;
}
# They must be okay, so return the user.
return $user;
}
#-------------------------------------------------------------------------------
#
# Separated gen_key from authen_cred
#
sub gen_key($$$)
{
my( $self, $r, $user, $refExtraData ) = @_;
my %c = _dbi_config_vars $r;
my $auth_name = $r->auth_name;
#----- Generate The Key Stuff...
# 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;
#---- CSA :: NEW 2.03 Session Stuff
# If we are using sessions, we create a new session for this login.
my $session_id = '';
if ( defined $c{ DBI_sessionmodule } ) {
my $dbh = DBI->connect( $c{ DBI_DSN },
$c{ DBI_user }, $c{ DBI_password } );
unless ( defined $dbh ) {
$r->log_error( "Apache2::AuthCookieDBI: couldn't connect to $c{ DBI_DSN } for auth realm $auth_name", $r->uri );
return undef;
}
my %session;
tie %session, $c{ DBI_sessionmodule }, undef, +{
Handle => $dbh,
LockHandle => $dbh,
};
$session_id = $session{ _session_id };
$r->pnotes( $auth_name, \%session );
$session{ user } = $user;
$session{ extra_data } = $refExtraData;
}
# OK, now we stick the username and the current time and the expire
# time and the session id (if any) 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:$session_id";
$public_part .= $self->extra_session_info($r,@Extra_Data);
#----- CSA :: End New 2.03 Session Stuff
# my $current_time = _now_year_month_day_hour_minute_second;
# my $public_part = "$enc_user:$current_time:$expire_time";
# OK, now we stick the username and the current time and the expire
# time and the session id (if any) 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:$session_id";
$public_part .= $self->extra_session_info($r,@Extra_Data);
# Now we calculate the hash of this and the secret key and then
# calculate the hash of *that* and the secret key again.
my $secretkey = $c{DBI_secretkey};
unless ( defined $secretkey ) {
$r->log_error( "Apache2::AuthCookieDBI: didn't have the secret key for auth realm $auth_name", $r->uri );
return undef;
}
my $hash = md5_hex( join ':', $secretkey, md5_hex(
join ':', $public_part, $secretkey
) );
# 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' ) {
( run in 2.061 seconds using v1.01-cache-2.11-cpan-ff9377addf4 )