package CGI::Application::Plugin::Authorization::Driver::DBIC;

use warnings;
use strict;
use base 'CGI::Application::Plugin::Authorization::Driver';

=head1 NAME

CGI::Application::Plugin::Authorization::Driver::DBIC - DBIx::Class Authorization Driver

=head1 VERSION

Version 0.01

=cut

our $VERSION = '0.01';

=head1 SYNOPSIS

use base qw(CGI::Application);
use CGI::Application::Plugin::Authentication;
   
__PACKAGE__->authz->config(
	DRIVER => [ 'DBIC',
		SCHEMA	=> $self->schema(),
		CLASS => 'User', # = My::DBIC::User
		CLASS_CONSTRAINTS => {
			username	=> '__USERNAME__',
		},# = My::DBIC::Users->resultset('User')->search(\%CLASS_CONSTRAINTS)->single()
		RELATION => 'groups', # My::DBIC::User->has_many('groups') / _->many_to_many('groups', ...)
		RELATION_CONSTRAINTS => {
			group		=> '__GROUP__',
		},# = My::DBIC::Users->resultset('User')->search(\%CLASS_CONSTRAINTS)->single()->groups( \%RELATION_CONSTRAINTS )
	],
);

# the same with CGI::Application::Plugin::Authorization::Driver::DBI
__PACKAGE__->authz->config(
	DRIVER => [ 'DBI',
		DBH         => $self->dbh(),
		TABLES      => ['users', 'users2groups', 'groups'],
		JOIN_ON     => 'users.user_id = users2groups.user_id AND users2groups.group_id = groups.group_id',
		CONSTRAINTS => {
		   'users.username'  => '__USERNAME__',
		   'groups.group' => '__GROUP__',
		}
	],
);


# Using a named configuration to distinguish it from
# the above configuration
__PACKAGE__->authz('privileges')->config(
	DRIVER => [ 'DBIC',
		SCHEMA	=> $self->schema(),
		CLASS => 'User',
		CLASS_CONSTRAINTS => {
			username	=> '__USERNAME__',
		},
		RELATION => 'privileges',
		RELATION_CONSTRAINTS => {
			package		=> '__PARAM_1__',
			privilege	=> '__PARAM_2__',
		},
	],
);


# TODO:
# a flat approach (not yet tested)
# suitable if there is a 1:1 relation between user and groups.
# (unfortunatley, this assumes a nonnormalized database layout)
__PACKAGE__->authz->config(
	DRIVER => [ 'DBIC',
		SCHEMA	=> $self->schema(),
		CLASS => 'User', # = My::DBIC::User
		CLASS_CONSTRAINTS => {
			username	=> '__USERNAME__',
			group		=> '__GROUP__',
		},
	],
);

=head1 DESCRIPTION

This Authorization driver uses the L<DBIx::Class> module to allow you to 
authorize against any I<DBIx::Class> class.

=head1 PARAMETERS

The I<DBIx::Class> Authentication driver accepts the following required
parameters.

=over 4

=item SCHEMA (required)

Specifies the I<DBIx::Class::Schema> object to use for Authorization. 
This class must be loaded prior to use.

=item CLASS (required)

Specifies the I<DBIx::Class> class within the schema which contains 
Authorization information or accessors to lookup authorization information (see relation).
Requires class constraints.

=item CLASS_CONSTRAINTS (required)

Specifies the constraints used to search for authenticating instances of the
I<DBIx::Class> class.

=item RELATION (optional)

RELATION is the name of the method in the I<DBIx::Class> class (CLASS),
that is accessed using RELATION_CONSTRAINTS.

Requires RELATION_CONSTRAINTS.

=back
    
=head1 METHODS

=head2 authorize_user

This method accepts a username followed by a list of parameters and will
return true if the configured query returns at least one row based on the
given parameters.

=cut

sub authorize_user {
    my $self     = shift;
    my $username = shift;
    my @params   = @_; # constraint values are in here (except username)

    # verify that all the options are OK
    my @_options = $self->options();
    die "The DBIC driver requires a hash of options" if @_options % 2;
    my %options = @_options;

	my $schema = $options{SCHEMA};
	die "SCHEMA option must be set." unless($schema);
    die "SCHEMA must be a DBIx::Class::Schema." unless($schema->isa('DBIx::Class::Schema'));
    # or like CAP::Authz::Driver::DBH ?
	## Get a schema handle either one that is given to us, or connect using
    ## the information given in the configuration
    #my $schema;
    #if ( $options{SCHEMA} ) {
    #    $dbh = $options{SCHEMA};
    #} elsif ( $self->authen->_cgiapp->can('schema') ) {
    #    $dbh = $self->authen->_cgiapp->schema();
    #} else {
    #    die "No SCHEMA and no schema() method detected";
    #}

	my $class = $options{CLASS};
	die "CLASS option must be set." unless($class);

	my $relation = $options{RELATION};
	die "RELATION option must be set." unless($relation);
	
	my $constraints_href = $options{CLASS_CONSTRAINTS};
	die "CLASS_CONSTRAINTS must be a hashref" unless ref $options{CLASS_CONSTRAINTS} eq 'HASH';

    # Process the constraints.
    # We need to check for values indicate they should be replaced by
    # a parameter (__PARAM_\d+__)
	my %class_constraints = ();
	my $used_username = 0;
	while ( my ( $column, $value ) = each %{ $options{CLASS_CONSTRAINTS} } ) {
        if ( $value =~ /^__PARAM_(\d+)__$/ ) {
            $value = $params[ $1 - 1 ];
        }
        elsif ( $value =~ /^__USERNAME__$/ ) {
            $value = $username;
            $used_username = 1;
        }
		elsif ( $value =~ /^__GROUP__$/ ) {
			$value = $params[ 0 ];
		}
		$class_constraints{$column} = $value;
	}
	
	if( $options{RELATION_CONSTRAINTS} ) {
		# There is also a relation to be checked.
		my %relation_constraints = ();
		my $used_username = 0;
		while ( my ( $column, $value ) = each %{ $options{RELATION_CONSTRAINTS} } ) {
			if ( $value =~ /^__PARAM_(\d+)__$/ ) {
				$value = $params[ $1 - 1 ];
			}
			elsif ( $value =~ /^__USERNAME__$/ ) {
				$value = $username;
				$used_username = 1;
			}
			elsif ( $value =~ /^__GROUP__$/ ) {
				$value = $params[ 0 ];
			}
			$relation_constraints{$column} = $value;
		}
		
		# Get the resultset.
		my $rs = $schema->resultset($class)->search(\%class_constraints)->single();
		
		# Check reltaion constraints.
		my $count = $rs->$relation(
			\%relation_constraints
		)->count();
		return $count ? 1 : 0;
	}
	
	# No relation to check. Only access the class.
	my $count = $schema->resultset($class)->search(\%class_constraints)->count();

    # See if we matched at least one row.
    return $count ? 1 : 0;
}




=head1 SEE ALSO

L<CGI::Application::Plugin::Authentication::Driver>, 
L<CGI::Application::Plugin::Authentication>, perl(1)

=head1 BUGS

Please report any bugs or feature requests to
C<bug-cgi-application-plugin-Authentication-driver-dbic at rt.cpan.org>, or through the web interface at
L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=CGI-Application-Plugin-Authentication-Driver-DBIC>.
I will be notified, and then you'll automatically be notified of progress on
your bug as I make changes.

=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc CGI::Application::Plugin::Authentication::Driver::DBIC

You can also look for information at:

=over 4

=item * AnnoCPAN: Annotated CPAN documentation

L<http://annocpan.org/dist/CGI-Application-Plugin-Authentication-Driver-DBIC>

=item * CPAN Ratings

L<http://cpanratings.perl.org/d/CGI-Application-Plugin-Authentication-Driver-DBIC>

=item * RT: CPAN's request tracker

L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=CGI-Application-Plugin-Authentication-Driver-DBIC>

=item * Search CPAN

L<http://search.cpan.org/dist/CGI-Application-Plugin-Authentication-Driver-DBIC>

=back

=head1 THANKS

Cees Hek for I<CGI::Application::Plugin::Authorization>

Jaldhar H. Vyas and his module I<CGI::Application::Plugin::Authentication::Driver::DBIC> and
Shawn Sorichetti I<CGI::Application::Plugin::Authentication::Driver::CDBI>.

=head1 AUTHOR

spam

=head1 COPYRIGHT & LICENSE

Copyright 2007, Consolidated Braincells Inc., all rights reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut

1; # End of CGI::Application::Plugin::Authentication::Driver::DBIC