File Coverage

blib/lib/Apache/DBILogin.pm

Criterion	Covered	Total	%
statement	11	13	84.6
branch			n/a
condition	1	2	50.0
subroutine	4	4	100.0
pod			n/a
total	16	19	84.2

package Apache::DBILogin;

use strict;

use vars qw($VERSION);
$VERSION = '2.06';

# setting the constants to help identify which version of mod_perl
# is installed
use constant MP2 => eval { require mod_perl2; 1 } || 0;

# test for the version of mod_perl, and use the appropriate libraries
BEGIN {
    if (MP2) {
        require Apache2::Access;
        require Apache2::Connection;
        require Apache2::Const;
        require Apache2::Log;
        require Apache2::RequestRec;
        require Apache2::RequestUtil;
        require APR::Table;
        Apache2::Const->import(-compile => 'HTTP_FORBIDDEN', 'HTTP_UNAUTHORIZED',
                                          'HTTP_INTERNAL_SERVER_ERROR', 'OK');
    } else {
        require mod_perl;
        require Apache::Constants;
        Apache::Constants->import('HTTP_FORBIDDEN', 'HTTP_UNAUTHORIZED',
                                  'HTTP_INTERNAL_SERVER_ERROR', 'OK');
    }
}

use DBI;

my(%Config) = (
    'Auth_DBI_data_source' => '',
    'Auth_DBI_authz_command' => '',
    'DBILogin_Oracle_authz_command' => '',
);
my $prefix = "Apache::DBILogin";

sub authen {
    my $r = shift @_;

    my ($res, $sent_pwd) = $r->get_basic_auth_pw;
    return $res if ( $res ); #decline if not Basic

    return (MP2 ? Apache2::Const::OK : Apache::Constants::OK)
        unless $r->is_initial_req;

    my($key,$val);
    my $attr = {};
    while(($key,$val) = each %Config) {
        $val = $r->dir_config($key) || $val;
        $key =~ s/^Auth_DBI_//;
        $attr->{$key} = $val;
    }

    return test_authen($r, $attr, $sent_pwd);
}

sub test_authen {
    my($r, $attr, $sent_pwd) = @_;

    my $user = MP2 ? $r->user : $r->connection->user;

    unless ( $attr->{data_source} ) {
        $r->log_reason("$prefix is missing the source parameter for database connect", $r->uri);
        return MP2 ? Apache2::Const::HTTP_INTERNAL_SERVER_ERROR : Apache::Constants::HTTP_INTERNAL_SERVER_ERROR;
    }

    my $dbh = DBI->connect($attr->{data_source}, $user, $sent_pwd, { AutoCommit=>0, RaiseError=>0 });
    unless( defined $dbh ) {
        $r->log_reason("user $user: $DBI::errstr", $r->uri);
        $r->note_basic_auth_failure;
        return MP2 ? Apache2::Const::HTTP_UNAUTHORIZED : Apache::Constants::HTTP_UNAUTHORIZED;
    }

    # to be removed in next version
    if ( $attr->{authz_command} ) {
        unless( defined ($dbh->do($attr->{authz_command})) ) {
            $r->log_reason("user $user: $DBI::errstr", $r->uri);
            $r->note_basic_auth_failure;
            return MP2 ? Apache2::Const::HTTP_UNAUTHORIZED : Apache::Constants::HTTP_UNAUTHORIZED;
        }
    }

    $dbh->disconnect;
    $r->headers_in->{'Modperl_DBILogin_Password'} = $sent_pwd;
    $r->headers_in->{'Modperl_Password'} = $sent_pwd;
    $r->headers_in->{'Modperl_DBILogin_data_source'} = $attr->{data_source};
    return MP2 ? Apache2::Const::OK : Apache::Constants::OK;
}

sub authz {
    my $r = shift @_;

    my ($res, $sent_pwd) = $r->get_basic_auth_pw;
    return $res if ( $res ); #decline if not Basic

    return (MP2 ? Apache2::Const::OK : Apache::Constants::OK)
        unless $r->is_initial_req;

    my $user = MP2 ? $r->user : $r->connection->user;

    my($key,$val);
    my $attr = {};
    while(($key,$val) = each %Config) {
        $val = $r->dir_config($key) || $val;
        $key =~ s/^Auth_DBI_//;
        $attr->{$key} = $val;
    }

    return test_authz($r, $attr, $sent_pwd);
}

sub test_authz {
    my($r, $attr, $sent_pwd) = @_;

    my $user = MP2 ? $r->user : $r->connection->user;

    unless ( $attr->{data_source} ) {
        $r->log_reason("$prefix is missing the source parameter for database connect", $r->uri);
        return MP2 ? Apache2::Const::HTTP_INTERNAL_SERVER_ERROR : Apache::Constants::HTTP_INTERNAL_SERVER_ERROR;
    }

    my $dbh = DBI->connect($attr->{data_source}, $user, $sent_pwd, {AutoCommit=>0, RaiseError=>0});
    unless( defined $dbh ) {
        $r->log_reason("user $user: $DBI::errstr", $r->uri);
        return MP2 ? Apache2::Const::HTTP_INTERNAL_SERVER_ERROR : Apache::Constants::HTTP_INTERNAL_SERVER_ERROR;
    }

    my $authz_result = MP2 ? Apache2::Const::HTTP_FORBIDDEN : Apache::Constants::HTTP_FORBIDDEN;
    my $sth;
    foreach my $requirement ( @{$r->requires} ) {
        my $require = $requirement->{requirement};
        if ( $require eq "valid-user" ) {
            $authz_result = MP2 ? Apache2::Const::OK : Apache::Constants::OK;
        } elsif ( $require =~ s/^user\s+// ) {
                foreach my $valid_user (split /\s+/, $require) {
                    if ( $user eq $valid_user ) {
                        $authz_result = MP2 ? Apache2::Const::OK : Apache::Constants::OK;
                        last;
                    }
                }
                if ( $authz_result != (MP2 ? Apache2::Const::OK : Apache::Constants::OK) ) {
                    my $explaination = <

Unauthorized

Unauthorized
User must be one of these required users: $require


END
                    $r->custom_response(MP2 ? Apache2::Const::HTTP_FORBIDDEN : Apache::Constants::HTTP_FORBIDDEN, $explaination);
                    $r->log_reason("user $user: not authorized", $r->uri);
                }
            } elsif ( $require =~ s/^group\s+// ) {
                    foreach my $group (split /\s+/, $require) {
                        $authz_result = is_member($r, $dbh, $group);
                        last if ( $authz_result == (MP2 ? Apache2::Const::OK : Apache::Constants::OK) );
                        if ( $authz_result == (MP2 ? Apache2::Const::HTTP_INTERNAL_SERVER_ERROR : Apache::Constants::HTTP_INTERNAL_SERVER_ERROR) ) {
                            $r->log_reason("user $user: $@", $r->uri);
                            return MP2 ? Apache2::Const::HTTP_INTERNAL_SERVER_ERROR : Apache::Constants::HTTP_INTERNAL_SERVER_ERROR;
                        }
                    }
                    if ( $authz_result == (MP2 ? Apache2::Const::HTTP_FORBIDDEN : Apache::Constants::HTTP_FORBIDDEN) ) {
                        my $explaination = <

Unauthorized

Unauthorized
User must be member of one of these required groups: $require


END
                        $r->custom_response(MP2 ? Apache2::Const::HTTP_FORBIDDEN : Apache::Constants::HTTP_FORBIDDEN, $explaination);
                        $r->log_reason("user $user: not authorized", $r->uri);
                    }
                }
    }

    $dbh->disconnect;
    return $authz_result;
}

1;

__END__