view release on metacpan or  search on metacpan

lib/Apache2/AuthCookieDBImg.pm  view on Meta::CPAN

the word in the images table via the key we get in credential_3.

For example, my randomizer (written in perl and called via a perl 
page template processor similar to Template::Toolkit) will spit out
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

=item C<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.

=item C<WhateverDBI_SecretKey>

Specifies the secret key for this auth scheme.  This should be a long
random string.  This should be secret; either make the httpd.conf file
only readable by root, or put the PerlSetVar in a file only readable by
root and include it.

This is required and has no default value.
(NOTE: In AuthCookieDBImg versions 1.22 and earlier the secret key either could be
or was required to be in a seperate file with the path configured with
PerlSetVar WhateverDBI_SecretKeyFile, as of version 2.0 this is not possible, you
must put the secret key in the Apache configuration directly, either in the main
httpd.conf file or in an included file.  You might wish to make the file not
world-readable. Also, make sure that the Perl environment variables are
not publically available, for example via the /perl-status handler.)
See also L</"COMPATIBILITY"> in this man page.

=item C<WhatEverDBI_User>

lib/Apache2/AuthCookieDBImg.pm  view on Meta::CPAN

and defaults to 'user'.

=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'.

=item C<WhatEverDBI_SessionLifetime>

How long tickets are good for after being issued.  Note that presently
Apache2::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.

=item C<WhatEverDBI_SessionModule>

Which Apache2::Session module to use for persistent sessions.
For example, a value could be "Apache2::Session::MySQL".  The DSN will
be the same as used for authentication.  The session created will be
stored in $r->pnotes( WhatEver ).

If you use this, you should put:

    PerlModule Apache2::Session::MySQL

(or whatever the name of your session module is) in your httpd.conf file,
so it is loaded.

If you are using this directive, you can timeout a session on the server side
by deleting the user''s session.  Authentication will then fail for them.

This is not required and defaults to none, meaning no session objects will
be created.

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

#===============================================================================