package Catalyst::Authentication::Store::DBI;
use strict;
use warnings;
use Catalyst::Authentication::Store::DBI::User;
our $VERSION = '0.01';
=head1 NAME
Catalyst::Authentication::Store::DBI - Storage class for Catalyst
Authentication using DBI
=head1 SYNOPSIS
use Catalyst qw(Authentication);
__PACKAGE__->config->{'authentication'} = {
'default_realm' => 'default',
'realms' => {
'default' => {
'credential' => {
'class' => 'Password',
'password_field' => 'password',
'password_type' => 'hashed',
'password_hash_type' => 'SHA-1',
},
'store' => {
'class' => 'DBI',
'user_table' => 'login',
'user_key' => 'id',
'user_name' => 'name',
'role_table' => 'authority',
'role_key' => 'id',
'role_name' => 'name',
'user_role_table' => 'competence',
'user_role_user_key' => 'login',
'user_role_role_key' => 'authority',
},
},
},
};
sub login :Global
{
my ($self, $c) = @_;
my $req = $c->request();
# catch login failures
unless ($c->authenticate({
'name' => $req->param('name'),
'password' => $req->param('password'),
})) {
...
}
...
}
sub something :Path
{
my ($self, $c) = @_;
# handle missing role case
unless ($c->check_user_roles('editor')) {
...
}
...
}
=head1 DESCRIPTION
This module implements the L<Catalyst::Authentication> API using
L<Catalyst::Model::DBI>.
It uses DBI to let your application authenticate users against a database and it
provides support for L<Catalyst::Plugin::Authorization::Roles>.
=head1 METHODS
=head2 new
=cut
# instantiates the store object
sub new
{
my ($class, $config, $app, $realm) = @_;
unless (defined($config) && ref($config) eq 'HASH') {
Catalyst::Exception->throw(__PACKAGE__ .
' needs a hashref for configuration');
}
my $self = {%$config};
bless($self, $class);
return $self;
}
=head2 find_user
=cut
# locates a user using data contained in the hashref
sub find_user
{
my ($self, $authinfo, $c) = @_;
my $sql;
my $sth;
my %user;
unless ($self->{'dbh'}) {
$self->{'dbh'} = $c->model('DBI')->dbh();
}
my $dbh = $self->{'dbh'};
my @col = map { $_ } sort(keys(%$authinfo));
$sql = 'SELECT * FROM ' . $self->{'user_table'} . ' WHERE ' .
join(' AND ', map { $_ . ' = ?' } @col);
$sth = $dbh->prepare($sql) or die($dbh->errstr());
$sth->execute(@$authinfo{@col}) or die($dbh->errstr());
$sth->bind_columns(\( @user{ @{ $sth->{'NAME_lc'} } } )) or
die($dbh->errstr());
unless ($sth->fetch()) {
$sth->finish();
return undef;
}
$sth->finish();
unless (exists($user{$self->{'user_key'}}) &&
length($user{$self->{'user_key'}})) {
return undef;
}
return Catalyst::Authentication::Store::DBI::User->new($self, \%user);
}
=head2 for_session
=cut
sub for_session
{
my ($self, $c, $user) = @_;
return $user->id();
}
=head2 from_session
=cut
sub from_session
{
my ($self, $c, $frozen) = @_;
my $sql;
my $sth;
my %user;
unless ($self->{'dbh'}) {
$self->{'dbh'} = $c->model('DBI')->dbh();
}
my $dbh = $self->{'dbh'};
$sql = 'SELECT * FROM ' . $self->{'user_table'} . ' WHERE ' .
$self->{'user_key'} . ' = ?';
$sth = $dbh->prepare($sql) or die($dbh->errstr());
$sth->execute($frozen) or die($dbh->errstr());
$sth->bind_columns(\( @user{ @{ $sth->{'NAME_lc'} } } )) or
die($dbh->errstr());
unless ($sth->fetch()) {
$sth->finish();
return undef;
}
$sth->finish();
unless (exists($user{$self->{'user_key'}}) &&
length($user{$self->{'user_key'}})) {
return undef;
}
return Catalyst::Authentication::Store::DBI::User->new($self, \%user);
}
=head2 user_supports
=cut
sub user_supports
{
my $self = shift;
return;
}
=head1 SEE ALSO
=over 4
=item L<Catalyst::Plugin::Authentication>
=item L<Catalyst::Model::DBI>
=item L<Catalyst::Plugin::Authorization::Roles>
=back
=head1 AUTHOR
Simon Bertrang, E<lt>simon.bertrang@puzzworks.comE<gt>
=head1 COPYRIGHT
Copyright (c) 2008 PuzzWorks OHG, L<http://puzzworks.com/>
=head1 LICENSE
This library is free software; you can redistribute it and/or modify it under
the same terms as Perl itself.
=cut
1;