You are viewing a plain text version of this content. The canonical link for it is here.
Posted to modperl-cvs@perl.apache.org by pg...@apache.org on 2008/12/24 05:31:56 UTC
svn commit: r729220 -
/perl/Apache-DBI/branches/AuthDBI_rewrite/lib/Apache/AuthDBI.pm
Author: pgollucci
Date: Tue Dec 23 20:31:56 2008
New Revision: 729220
URL: http://svn.apache.org/viewvc?rev=729220&view=rev
Log:
90% of a rewrite, doesn't work as it, needs testing
Modified:
perl/Apache-DBI/branches/AuthDBI_rewrite/lib/Apache/AuthDBI.pm
Modified: perl/Apache-DBI/branches/AuthDBI_rewrite/lib/Apache/AuthDBI.pm
URL: http://svn.apache.org/viewvc/perl/Apache-DBI/branches/AuthDBI_rewrite/lib/Apache/AuthDBI.pm?rev=729220&r1=729219&r2=729220&view=diff
==============================================================================
--- perl/Apache-DBI/branches/AuthDBI_rewrite/lib/Apache/AuthDBI.pm (original)
+++ perl/Apache-DBI/branches/AuthDBI_rewrite/lib/Apache/AuthDBI.pm Tue Dec 23 20:31:56 2008
@@ -1,17 +1,21 @@
# $Id$
package Apache::AuthDBI;
+### core
+use strict;
+use warnings FATAL => 'all';
+use Carp;
-$Apache::AuthDBI::VERSION = '1.08-dev';
-
-# 1: report about cache miss
-# 2: full debug output
-$Apache::AuthDBI::DEBUG = 0;
-
-use constant MP2 => (exists $ENV{MOD_PERL_API_VERSION}
- && $ENV{MOD_PERL_API_VERSION} == 2) ? 1 : 0;
+### cpan
+use DBI ();
+use Digest::MD5 ();
+use Digest::SHA1 ();
+use SysV::IPC ();
+### mp
+use constant MP2 => (exists $ENV{MOD_PERL_API_VERSION} &&
+ $ENV{MOD_PERL_API_VERSION} == 2) ? 1 : 0;
BEGIN {
- my @constants = qw( OK AUTH_REQUIRED FORBIDDEN DECLINED SERVER_ERROR );
+ my @constants = qw(OK AUTH_REQUIRED FORBIDDEN DECLINED SERVER_ERROR);
if (MP2) {
require Apache2::Access;
require Apache2::Const;
@@ -25,1571 +29,658 @@
}
}
-use strict;
-use DBI ();
-use Digest::SHA1 ();
-use Digest::MD5 ();
-
-sub debug {
- print STDERR "$_[1]\n" if $_[0] <= $Apache::AuthDBI::DEBUG;
-}
+### Version
+our $VERSION = '1.08-dev';
-sub push_handlers {
- if (MP2) {
- require Apache2::ServerUtil;
- my $s = Apache2::ServerUtil->server;
- $s->push_handlers(@_);
- }
- else {
- Apache->push_handlers(@_);
- }
-}
+### Constants
+use constant SEM_LOCK_GET =>
+ pack("sss", 0, 0, 0) . pack("sss", 0, 1, 0);
+use constant SEM_LOCK_RELEASE => pack("sss", 0, -1, 0);
+
+## ENVs
+use constant REMOTE_PASSWORD => 'REMOTE_PASSWORD';
+use constant REMOTE_PASSWORDS => 'REMOTE_PASSWORDS';
+use constant REMOTE_GROUP => 'REMOTE_GROUP';
+use constant REMOTE_GROUPS => 'REMOTE_GROUPS';
+use constant AUTH_SHEMID => 'AUTH_SEMID';
+use constant AUTH_SHMID => 'AUTH_SHMID';
+
+## Debugging
+use constant DEBUG_NONE => 0x00000000;
+use constant DEBUG_CONF => 0x00000001;
+use constant DEBUG_DB => 0x00000010;
+use constant DEBUG_SQL => 0x00000100;
+use constant DEBUG_CACHE => 0x00001000;
+use constant DEBUG_REQ => 0x00010000;
+use constant DEBUG_PW => 0x00100000;
+#
+#
+use constant DEBUG_ALL => 0x11111111;
+
+### Globals
+our $Debug = DEBUG_NONE;
+my $Default_Config = {
+# Auth_DBI_data_source => '',
+# Auth_DBI_username => '',
+# Auth_DBI_password => '',
+# Auth_DBI_pwd_table => '',
+# Auth_DBI_uid_field => '',
+# Auth_DBI_pwd_field => '',
+# Auth_DBI_pwd_whereclause => '',
+# Auth_DBI_grp_table => '',
+# Auth_DBI_grp_field => '',
+# Auth_DBI_grp_whereclause => '',
+# Auth_DBI_log_field => '',
+# Auth_DBI_log_string => '',
+# Auth_DBI_authoritative => 'on',
+# Auth_DBI_nopasswd => 'off',
+#dead Auth_DBI_encrypted => 'on',
+# Auth_DBI_encryption_salt => 'password',
+# # Using Two (or more) Methods Will Allow for Fallback to older Methods
+# Auth_DBI_encryption_method => 'sha1hex/md5/crypt',
+# Auth_DBI_encryption_method => 'plain',
+ Auth_DBI_uidcasesensitive => 'on',
+ Auth_DBI_pwdcasesensitive => 'on',
+ Auth_DBI_placeholder => 'off',
+ Auth_DBI_expeditive => 'on',
+ };
+
+our %db_attrs = (
+ RaiseError => 1,
+ PrintError => 0,
+ Taint => 0,
+ AutoCommit => 1,
+ LongReadLen => 50000,
+ LongTruncOk => 1,
+ ShowErrorStatement => 1,
+ ChopBlanks => 1,
+ FetchHashKeyName => "NAME_lc",
+ );
+
+### Cache
+my $Cache_Conf = ();
+my $Cache_Reqs = ();
+
+##########################################################################
+## #
+## Handlers #
+## #
+##########################################################################
+# user_sent - user name as user typed it
+# pw_sent - pw as user typed it
+# pws_sent_crypted - hashref based on pw_sent: 1 key for each enc method,
+# value is crypt algorithm
+# pws_db - array ref of pws for user_sent as they are in the DB
-# configuration attributes, defaults will be overwritten with values
-# from .htaccess.
-my %Config = (
- 'Auth_DBI_data_source' => '',
- 'Auth_DBI_username' => '',
- 'Auth_DBI_password' => '',
- 'Auth_DBI_pwd_table' => '',
- 'Auth_DBI_uid_field' => '',
- 'Auth_DBI_pwd_field' => '',
- 'Auth_DBI_pwd_whereclause' => '',
- 'Auth_DBI_grp_table' => '',
- 'Auth_DBI_grp_field' => '',
- 'Auth_DBI_grp_whereclause' => '',
- 'Auth_DBI_log_field' => '',
- 'Auth_DBI_log_string' => '',
- 'Auth_DBI_authoritative' => 'on',
- 'Auth_DBI_nopasswd' => 'off',
- 'Auth_DBI_encrypted' => 'on',
- 'Auth_DBI_encryption_salt' => 'password',
- #Using Two (or more) Methods Will Allow for Fallback to older Methods
- 'Auth_DBI_encryption_method'=> 'sha1hex/md5/crypt',
- 'Auth_DBI_uidcasesensitive' => 'on',
- 'Auth_DBI_pwdcasesensitive' => 'on',
- 'Auth_DBI_placeholder' => 'off',
- 'Auth_DBI_expeditive' => 'on',
- );
-
-# stores the configuration of current URL.
-# initialized during authentication, eventually re-used for authorization.
-my $Attr = {};
-
-# global cache: all records are put into one string.
-# record separator is a newline. Field separator is $;.
-# every record is a list of id, time of last access, password, groups
-#(authorization only).
-# the id is a comma separated list of user_id, data_source, pwd_table,
-# uid_field.
-# the first record is a timestamp, which indicates the last run of the
-# CleanupHandler followed by the child counter.
-my $Cache = time . "$;0\n";
-
-# unique id which serves as key in $Cache.
-# the id is generated during authentication and re-used for authorization.
-my $ID;
-
-# minimum lifetimes of cache entries in seconds.
-# setting the CacheTime to 0 will not use the cache at all.
-my $CacheTime = 0;
-
-# supposed to be called in a startup script.
-# sets CacheTime to a user defined value.
-sub setCacheTime {
- my $class = shift;
- my $cache_time = shift;
-
- # sanity check
- $CacheTime = $cache_time if $cache_time =~ /\d+/;
-}
-
-# minimum time interval in seconds between two runs of the PerlCleanupHandler.
-# setting CleanupTime to 0 will run the PerlCleanupHandler after every request.
-# setting CleanupTime to a negative value will disable the PerlCleanupHandler.
-my $CleanupTime = -1;
-
-# supposed to be called in a startup script.
-# sets CleanupTime to a user defined value.
-sub setCleanupTime {
- my $class = shift;
- my $cleanup_time = shift;
-
- # sanity check
- $CleanupTime = $cleanup_time if $cleanup_time =~ /\-*\d+/;
-}
-
-# optionally the string with the global cache can be stored in a shared memory
-# segment. the segment will be created from the first child and it will be
-# destroyed if the last child exits. the reason for not handling everything
-# in the main server is simply, that there is no way to setup
-# an ExitHandler which runs in the main server and which would remove the
-# shared memory and the semaphore.hence we have to keep track about the
-# number of children, so that the last one can do all the cleanup.
-# creating the shared memory in the first child also has the advantage,
-# that we don't have to cope with changing the ownership. if a shm-function
-# fails, the global cache will automatically fall back to one string
-# per process.
-my $SHMKEY = 0; # unique key for shared memory segment and semaphore set
-my $SEMID = 0; # id of semaphore set
-my $SHMID = 0; # id of shared memory segment
-my $SHMSIZE = 50000; # default size of shared memory segment
-my $SHMPROJID = 1; # default project id for shared memory segment
-
-# Supposed to be called in a startup script.
-# Sets SHMPROJID to a user defined value
-sub setProjID {
- my $class = shift;
- my $shmprojid = shift;
-
- #Set ProjID prior to calling initIPC!
- return if $SHMKEY;
-
- # sanity check - Must be numeric and less than or equal to 255
- $SHMPROJID = int($shmprojid)
- if $shmprojid =~ /\d{1,3}/ && $shmprojid <= 255 && $shmprojid > 0;
-}
-
-# shortcuts for semaphores
-my $obtain_lock = pack("sss", 0, 0, 0) . pack("sss", 0, 1, 0);
-my $release_lock = pack("sss", 0, -1, 0);
-
-# supposed to be called in a startup script.
-# sets SHMSIZE to a user defined value and initializes the unique key,
-# used for the shared memory segment and for the semaphore set.
-# creates a PerlChildInitHandler which creates the shared memory segment
-# and the semaphore set. creates a PerlChildExitHandler which removes
-# the shared memory segment and the semaphore set upon server shutdown.
-# keep in mind, that this routine runs only once, when the main server
-#starts up.
-sub initIPC {
- my $class = shift;
- my $shmsize = shift;
-
- require IPC::SysV;
-
- # make sure, this method is called only once
- return if $SHMKEY;
-
- # ensure minimum size of shared memory segment
- $SHMSIZE = $shmsize if $shmsize >= 500;
-
- # generate unique key based on path of AuthDBI.pm + SHMPROJID
- foreach my $file (keys %INC) {
- if ($file eq 'Apache/AuthDBI.pm') {
- $SHMKEY = IPC::SysV::ftok($INC{$file}, $SHMPROJID);
- last;
- }
- }
-
- # provide a handler which initializes the shared memory segment
- #(first child) or which increments the child counter.
- push_handlers(PerlChildInitHandler => \&childinit);
-
- # provide a handler which decrements the child count or which
- # destroys the shared memory
- # segment upon server shutdown, which is defined by the exit of the
- # last child.
- push_handlers(PerlChildExitHandler => \&childexit);
-}
-
-# authentication handler
sub authen {
- my ($r) = @_;
-
- my ($key, $val, $dbh);
- my $prefix = "$$ Apache::AuthDBI::authen";
-
- if ($Apache::AuthDBI::DEBUG > 1) {
- my $type = '';
- if (MP2) {
- $type .= 'initial ' if $r->is_initial_req();
- $type .= 'main' if $r->main();
- }
- else {
- $type .= 'initial ' if $r->is_initial_req;
- $type .= 'main' if $r->is_main;
- }
- debug (1, "==========\n$prefix request type = >$type<");
- }
-
- return MP2 ? Apache2::Const::OK() : Apache::Constants::OK()
- unless $r->is_initial_req; # only the first internal request
-
- debug (2, "REQUEST:" . $r->as_string);
-
- # here the dialog pops up and asks you for username and password
- my ($res, $passwd_sent) = $r->get_basic_auth_pw;
- {
- no warnings qw(uninitialized);
- debug (2, "$prefix get_basic_auth_pw: res = >$res<, password sent = >$passwd_sent<");
- }
- return $res if $res; # e.g. HTTP_UNAUTHORIZED
-
- # get username
- my $user_sent = $r->user;
- debug(2, "$prefix user sent = >$user_sent<");
-
- # do we use shared memory for the global cache ?
- debug (2, "$prefix cache in shared memory, shmid $SHMID, shmsize $SHMSIZE, semid $SEMID");
-
- # get configuration
- while(($key, $val) = each %Config) {
- $val = $r->dir_config($key) || $val;
- $key =~ s/^Auth_DBI_//;
- $Attr->{$key} = $val;
- debug(2, sprintf("$prefix Config{ %-16s } = %s", $key, $val));
- }
-
- # parse connect attributes, which may be tilde separated lists
- my @data_sources = split /~/, $Attr->{data_source};
- my @usernames = split /~/, $Attr->{username};
- my @passwords = split /~/, $Attr->{password};
- # use ENV{DBI_DSN} if not defined
- $data_sources[0] = '' unless $data_sources[0];
-
- # obtain the id for the cache
- # remove any embedded attributes, because of trouble with regexps
- my $data_src = $Attr->{data_source};
- $data_src =~ s/\(.+\)//g;
-
- $ID = join ',',
- $user_sent, $data_src, $Attr->{pwd_table}, $Attr->{uid_field};
-
- # if not configured decline
- unless ($Attr->{pwd_table} && $Attr->{uid_field} && $Attr->{pwd_field}) {
- debug (2, "$prefix not configured, return DECLINED");
- return MP2 ? Apache2::Const::DECLINED() :
- Apache::Constants::DECLINED();
- }
-
- # do we want Windows-like case-insensitivity?
- $user_sent = lc $user_sent if $Attr->{uidcasesensitive} eq "off";
- $passwd_sent = lc $passwd_sent if $Attr->{pwdcasesensitive} eq "off";
-
- # check whether the user is cached but consider that the password
- # possibly has changed
- my $passwd = '';
- if ($CacheTime) { # do we use the cache ?
- if ($SHMID) { # do we keep the cache in shared memory ?
- semop($SEMID, $obtain_lock)
- or warn "$prefix semop failed \n";
- shmread($SHMID, $Cache, 0, $SHMSIZE)
- or warn "$prefix shmread failed \n";
- substr($Cache, index($Cache, "\0")) = '';
- semop($SEMID, $release_lock)
- or warn "$prefix semop failed \n";
- }
- # find id in cache
- my ($last_access, $passwd_cached, $groups_cached);
- if ($Cache =~ /$ID$;(\d+)$;(.+)$;(.*)\n/) {
- $last_access = $1;
- $passwd_cached = $2;
- $groups_cached = $3;
- debug(2, "$prefix cache: found >$ID< >$last_access< >$passwd_cached<");
-
- my @passwds_to_check =
- &get_passwds_to_check(
- $Attr,
- user_sent => $user_sent,
- passwd_sent => $passwd_sent,
- password => $passwd_cached
- );
-
- debug(2, "$prefix " . scalar(@passwds_to_check) . " passwords to check");
- foreach my $passwd_to_check (@passwds_to_check) {
- # match cached password with password sent
- $passwd = $passwd_cached if $passwd_to_check eq $passwd_cached;
- last if $passwd;
- }
- }
- }
-
- # found in cache
- if ($passwd) {
- debug(2, "$prefix passwd found in cache");
- }
- else {
- # password not cached or changed
- debug (2, "$prefix passwd not found in cache");
-
- # connect to database, use all data_sources until the connect succeeds
- for (my $j = 0; $j <= $#data_sources; $j++) {
- last if (
- $dbh = DBI->connect(
- $data_sources[$j],
- $usernames[$j],
- $passwords[$j]
- )
- );
- }
- unless ($dbh) {
- $r->log_reason(
- "$prefix db connect error with data_source " .
- ">$Attr->{data_source}<: $DBI::errstr",
- $r->uri
- );
- return MP2 ? Apache2::Const::SERVER_ERROR() :
- Apache::Constants::SERVER_ERROR();
- }
+ my $r = shift;
- # generate statement
- my $user_sent_quoted = $dbh->quote($user_sent);
- my $select = "SELECT $Attr->{pwd_field}";
- my $from = "FROM $Attr->{pwd_table}";
- my $where = ($Attr->{uidcasesensitive} eq "off") ?
- "WHERE lower($Attr->{uid_field}) =" :
- "WHERE $Attr->{uid_field} =";
- my $compare = ($Attr->{placeholder} eq "on") ?
- "?" : "$user_sent_quoted";
- my $statement = "$select $from $where $compare";
- $statement .= " AND $Attr->{pwd_whereclause}"
- if $Attr->{pwd_whereclause};
-
- debug(2, "$prefix statement: $statement");
-
- # prepare statement
- my $sth;
- unless ($sth = $dbh->prepare($statement)) {
- $r->log_reason("$prefix can not prepare statement: $DBI::errstr", $r->uri);
- $dbh->disconnect;
- return MP2 ? Apache2::Const::SERVER_ERROR() :
- Apache::Constants::SERVER_ERROR();
- }
+ debug($r, DEBUG_REQ, $r->as_string);
- # execute statement
- my $rv;
- unless ($rv = ($Attr->{placeholder} eq "on") ?
- $sth->execute($user_sent) : $sth->execute) {
- $r->log_reason("$prefix can not execute statement: $DBI::errstr", $r->uri);
- $dbh->disconnect;
- return MP2 ? Apache2::Const::SERVER_ERROR() :
- Apache::Constants::SERVER_ERROR();
- }
+ return _ok() unless $r->is_initial_req;
- my $password;
- $sth->execute();
- $sth->bind_columns(\$password);
- my $cnt = 0;
- while ($sth->fetch()) {
- $password =~ s/ +$// if $password;
- $passwd .= "$password$;";
- $cnt++;
- }
+ my ($res, $pw_sent) = $r->get_basic_auth_pw;
+ debug($r, DEBUG_REQ, "res => [$rew], pw_sent => [$pw_sent]");
+ return $res if $res;
- chop $passwd if $passwd;
- # so we can distinguish later on between no password and empty password
- undef $passwd if 0 == $cnt;
-
- if ($sth->err) {
- $dbh->disconnect;
- return MP2 ? Apache2::Const::SERVER_ERROR() :
- Apache::Constants::SERVER_ERROR();
- }
- $sth->finish;
+ my $conf = config_request_load($r);
+ debug($r, DEBUG_REQ, "prefix not configured, DECLINED"),
+ return _declined() unless config_uri_configured($conf);
- # re-use dbh for logging option below
- $dbh->disconnect unless $Attr->{log_field} && $Attr->{log_string};
- }
+ my $user_sent =
+ $conf->{uidcasesensitive} =~ /on/i ? lc($r->user) : $r->user;
- $r->subprocess_env(REMOTE_PASSWORDS => $passwd);
- debug(2, "$prefix passwd = >$passwd<");
+ my ($pws_db, $status) = db_pws_get($r, $conf, $user_sent);
+ return $status if $status;
- # check if password is needed
- unless ($passwd) { # not found in database
- # if authoritative insist that user is in database
- if ($Attr->{authoritative} eq 'on') {
- $r->log_reason("$prefix password for user $user_sent not found", $r->uri);
+ unless (@$pws_db > 0) {
+ ## No records found
+ ## continue the Chain or stop?
+ if ($conf->{authoritative} =~ /on/i) {
+ logr($r, "pw for $user_sent not found");
$r->note_basic_auth_failure;
- return MP2 ? Apache2::Const::AUTH_REQUIRED() :
- Apache::Constants::AUTH_REQUIRED();
+ return _auth_required();
}
else {
- # else pass control to the next authentication module
- return MP2 ? Apache2::Const::DECLINED() :
- Apache::Constants::DECLINED();
+ return _declined();
}
- }
-
- # allow any password if nopasswd = on and the retrieved password is empty
- if ($Attr->{nopasswd} eq 'on' && !$passwd) {
- return MP2 ? Apache2::Const::OK() : Apache::Constants::OK();
- }
- # if nopasswd is off, reject user
- unless ($passwd_sent && $passwd) {
- $r->log_reason("$prefix user $user_sent: empty password(s) rejected", $r->uri);
- $r->note_basic_auth_failure;
- return MP2 ? Apache2::Const::AUTH_REQUIRED() :
- Apache::Constants::AUTH_REQUIRED();
+ ## blanket access
+ $conf->{nopwasswd} =~ /on/i ? _ok() : _auth_required();
}
- # compare passwords
- my $found = 0;
- foreach my $password (split /$;/, $passwd) {
- # compare all the passwords using as many encryption methods
- # in fallback as needed
- my @passwds_to_check =
- &get_passwds_to_check(
- $Attr,
- user_sent => $user_sent,
- passwd_sent => $passwd_sent,
- password => $password
- );
-
- debug (2, "$prefix " . scalar(@passwds_to_check) . " passwords to check");
-
- foreach my $passwd_to_check (@passwds_to_check) {
- debug(
- 2,
- "$prefix user $user_sent: Password after Preparation " .
- ">$passwd_to_check< - trying for a match with >$password<"
- );
-
- if ($passwd_to_check eq $password) {
- $found = 1;
- $r->subprocess_env(REMOTE_PASSWORD => $password);
- debug (
- 2,
- "$prefix user $user_sent: Password from Web Server " .
- ">$passwd_sent< - Password after Preparation >$passwd_to_check< - " .
- "password match for >$password<"
- );
-
- # update timestamp and cache userid/password if CacheTime
- # is configured
- if ($CacheTime) { # do we use the cache ?
- if ($SHMID) { # do we keep the cache in shared memory ?
- semop($SEMID, $obtain_lock)
- or warn "$prefix semop failed \n";
- shmread($SHMID, $Cache, 0, $SHMSIZE)
- or warn "$prefix shmread failed \n";
- substr($Cache, index($Cache, "\0")) = '';
- }
-
- # update timestamp and password or append new record
- my $now = time;
- if (!($Cache =~ s/$ID$;\d+$;.*$;(.*)\n/$ID$;$now$;$password$;$1\n/)) {
- $Cache .= "$ID$;$now$;$password$;\n";
- }
-
- if ($SHMID) { # write cache to shared memory
- shmwrite($SHMID, $Cache, 0, $SHMSIZE)
- or warn "$prefix shmwrite failed \n";
- semop($SEMID, $release_lock)
- or warn "$prefix semop failed \n";
- }
- }
- last;
- }
- }
+ my ($pws_sent_crypted) =
+ crypt_pws_get($r, $conf, $user_sent, $pw_sent);
- #if the passwd matched (encrypted or otherwise), don't check the
- # myriad other passwords that may or may not exist
- last if $found > 0 ;
- }
-
- unless ($found) {
- $r->log_reason("$prefix user $user_sent: password mismatch", $r->uri);
+ my $match = pw_match_any($r, $user_sent, $pws_sent_crypted, $pws_db);
+ unless ($match) {
+ logr("$user_sent: password mismatch");
$r->note_basic_auth_failure;
- return MP2 ? Apache2::Const::AUTH_REQUIRED() :
- Apache::Constants::AUTH_REQUIRED();
- }
-
- # logging option
- if ($Attr->{log_field} && $Attr->{log_string}) {
- if (!$dbh) { # connect to database if not already done
- my $connect;
- for (my $j = 0; $j <= $#data_sources; $j++) {
- if ($dbh = DBI->connect(
- $data_sources[$j],
- $usernames[$j],
- $passwords[$j]
- )) {
- $connect = 1;
- last;
- }
- }
- unless ($connect) {
- $r->log_reason("$prefix db connect error with $Attr->{data_source}", $r->uri);
- return MP2 ? Apache2::Const::SERVER_ERROR() :
- Apache::Constants::SERVER_ERROR();
- }
- }
- my $user_sent_quoted = $dbh->quote($user_sent);
- my $statement = "UPDATE $Attr->{pwd_table} SET $Attr->{log_field} = " .
- "$Attr->{log_string} WHERE $Attr->{uid_field}=$user_sent_quoted";
-
- debug(2, "$prefix statement: $statement");
-
- unless ($dbh->do($statement)) {
- $r->log_reason("$prefix can not do statement: $DBI::errstr", $r->uri);
- $dbh->disconnect;
- return MP2 ? Apache2::Const::SERVER_ERROR() :
- Apache::Constants::SERVER_ERROR();
- }
- $dbh->disconnect;
- }
-
- # Unless the cache or the CleanupHandler is disabled, the
- # CleanupHandler is initiated if the last run was more than
- # $CleanupTime seconds before.
- # Note, that it runs after the request, hence it cleans also the
- # authorization entries
- if ($CacheTime and $CleanupTime >= 0) {
- my $diff = time - substr $Cache, 0, index($Cache, "$;");
- debug(
- 2,
- "$prefix secs since last CleanupHandler: $diff, CleanupTime: " .
- "$CleanupTime"
- );
-
- if ($diff > $CleanupTime) {
- debug (2, "$prefix push PerlCleanupHandler");
- push_handlers(PerlCleanupHandler => \&cleanup);
- }
+ return _auth_required();
}
- debug (2, "$prefix return OK\n");
- return MP2 ? Apache2::Const::OK() : Apache::Constants::OK();
-}
-
-#Encrypts a password in all supported/requested methods and passes back
-#array for comparison
-sub get_passwds_to_check {
- my $Attr = shift;
- my %params = @_;
-
-
- my ($prefix) = "$$ Apache::AuthDBI::get_passwds_to_check ";
-
- my ($salt, @passwds_to_check);
-
- if ($Attr->{encrypted} eq 'on') {
- #SHA1
- if ($Attr->{encryption_method} =~ /(^|\/)sha1hex($|\/)/i) {
- push @passwds_to_check, SHA1_digest(
- text => $params{'passwd_sent'},
- format => 'hex'
- );
- }
-
- #MD5
- if ($Attr->{encryption_method} =~ /(^|\/)md5hex($|\/)/i) {
- push @passwds_to_check, MD5_digest(
- text => $params{'passwd_sent'},
- format => 'hex'
- );
- }
-
- #CRYPT
- if ($Attr->{encryption_method} =~ /(^|\/)crypt($|\/)/i) {
- $salt = $Attr->{encryption_salt} eq 'userid' ?
- $params{'user_sent'} : $params{'password'};
- #Bug Fix in v0.94 (marked as 0.93 in file. salt was NOT being sent
- # to crypt) - KAM - 06-16-2005
- push @passwds_to_check, crypt($params{'passwd_sent'}, $salt);
- }
-
- #WE DIDN'T GET ANY PASSWORDS TO CHECK. MUST BE A PROBLEM
- if (scalar(@passwds_to_check) < 1) {
- debug (2, "$prefix Error: No Valid Encryption Method Specified");
- }
- }
- else {
- #IF NO ENCRYPTION, JUST PUSH THE CLEARTEXT PASS
- push @passwds_to_check, $params{'passwd_sent'};
- }
+ debug($r, DEBUG_REQ, "OK");
- return (@passwds_to_check);
+ return _ok();
}
-# authorization handler, it is called immediately after the authentication
sub authz {
my $r = shift;
- my ($key, $val, $dbh);
- my $prefix = "$$ Apache::AuthDBI::authz ";
-
- if ($Apache::AuthDBI::DEBUG > 1) {
- my $type = '';
- if (MP2) {
- $type .= 'initial ' if $r->is_initial_req();
- $type .= 'main' if $r->main();
- }
- else {
- $type .= 'initial ' if $r->is_initial_req;
- $type .= 'main' if $r->is_main;
- }
- debug(1, "==========\n$prefix request type = >$type<");
- }
-
- # only the first internal request
- unless ($r->is_initial_req) {
- return MP2 ? Apache2::Const::OK() : Apache::Constants::OK();
- }
-
- my $user_result = MP2 ? Apache2::Const::DECLINED() :
- Apache::Constants::DECLINED();
- my $group_result = MP2 ? Apache2::Const::DECLINED() :
- Apache::Constants::DECLINED();
+ return _ok() unless $r->is_initial_req;
- # get username
my $user_sent = $r->user;
- debug(2, "$prefix user sent = >$user_sent<");
- # here we could read the configuration, but we re-use the configuration
- # from the authentication
-
- # parse connect attributes, which may be tilde separated lists
- my @data_sources = split /~/, $Attr->{data_source};
- my @usernames = split /~/, $Attr->{username};
- my @passwords = split /~/, $Attr->{password};
- # use ENV{DBI_DSN} if not defined
- $data_sources[0] = '' unless $data_sources[0];
-
- # if not configured decline
- unless ($Attr->{pwd_table} && $Attr->{uid_field} && $Attr->{grp_field}) {
- debug(2, "$prefix not configured, return DECLINED");
- return MP2 ? Apache2::Const::DECLINED() :
- Apache::Constants::DECLINED();
- }
-
- # do we want Windows-like case-insensitivity?
- $user_sent = lc $user_sent if $Attr->{uidcasesensitive} eq "off";
-
- # select code to return if authorization is denied:
- my $authz_denied;
- if (MP2) {
- $authz_denied = $Attr->{expeditive} eq 'on' ?
- Apache2::Const::FORBIDDEN() : Apache2::Const::AUTH_REQUIRED();
- }
- else {
- $authz_denied = $Attr->{expeditive} eq 'on' ?
- Apache::Constants::FORBIDDEN() : Apache::Constants::AUTH_REQUIRED();
- }
-
- # check if requirements exists
- my $ary_ref = $r->requires;
- unless ($ary_ref) {
- if ($Attr->{authoritative} eq 'on') {
- $r->log_reason("user $user_sent denied, no access rules specified (DBI-Authoritative)", $r->uri);
- if ($authz_denied == (MP2 ? Apache2::Const::AUTH_REQUIRED() :
- Apache::Constants::AUTH_REQUIRED())) {
- $r->note_basic_auth_failure;
- }
- return $authz_denied;
- }
- debug (2, "$prefix no requirements and not authoritative, return DECLINED");
- return MP2 ? Apache2::Const::DECLINED() :
- Apache::Constants::DECLINED();
- }
-
- # iterate over all requirement directives and store them according to
- # their type (valid-user, user, group)
- my($valid_user, $user_requirements, $group_requirements);
- foreach my $hash_ref (@$ary_ref) {
- while (($key,$val) = each %$hash_ref) {
- last if $key eq 'requirement';
- }
- $val =~ s/^\s*require\s+//;
-
- # handle different requirement-types
- if ($val =~ /valid-user/) {
- $valid_user = 1;
- }
- elsif ($val =~ s/^user\s+//g) {
- $user_requirements .= " $val";
- }
- elsif ($val =~ s/^group\s+//g) {
- $group_requirements .= " $val";
- }
- }
- $user_requirements =~ s/^ //g if $user_requirements;
- $group_requirements =~ s/^ //g if $group_requirements;
-
- {
- no warnings qw(uninitialized);
-
- debug(
- 2,
- "$prefix requirements: [valid-user=>$valid_user<] [user=>" .
- "$user_requirements<] [group=>$group_requirements<]"
- );
- }
-
- # check for valid-user
- if ($valid_user) {
- $user_result = MP2 ? Apache2::Const::OK() : Apache::Constants::OK();
- debug(2, "$prefix user_result = OK: valid-user");
- }
-
- # check for users
- if (($user_result != (MP2 ? Apache2::Const::OK() :
- Apache::Constants::OK())) && $user_requirements) {
-
- $user_result = MP2 ? Apache2::Const::AUTH_REQUIRED() :
- Apache::Constants::AUTH_REQUIRED();
-
- foreach my $user_required (split /\s+/, $user_requirements) {
- if ($user_required eq $user_sent) {
- debug (2, "$prefix user_result = OK for $user_required");
- $user_result = MP2 ? Apache2::Const::OK() :
- Apache::Constants::OK();
- last;
- }
- }
- }
-
- my $user_result_valid = MP2 ? Apache2::Const::OK() :
- Apache::Constants::OK();
-
- # check for groups
- if ($user_result != $user_result_valid && $group_requirements) {
- debug(2, "$prefix: checking for groups >$group_requirements<");
- $group_result = MP2 ? Apache2::Const::AUTH_REQUIRED() : Apache::Constants::AUTH_REQUIRED();
- my $group;
-
- # check whether the user is cached but consider that the group
- # possibly has changed
- my $groups = '';
- if ($CacheTime) { # do we use the cache ?
- # we need to get the cached groups for the current id,
- # which has been read already
- # during authentication, so we do not read the Cache from
- # shared memory again
- my ($last_access, $passwd_cached, $groups_cached);
- if ($Cache =~ /$ID$;(\d+)$;(.*)$;(.+)\n/) {
- $last_access = $1;
- $passwd_cached = $2;
- $groups_cached = $3;
- debug(2, "$prefix cache: found >$ID< >$last_access< >$groups_cached");
-
- REQUIRE_1:
- foreach my $group_required (split /\s+/, $group_requirements) {
- foreach $group (split(/,/, $groups_cached)) {
- if ($group_required eq $group) {
- $groups = $groups_cached;
- last REQUIRE_1;
- }
- }
- }
- }
- }
-
- # found in cache
- if ($groups) {
- debug(2, "$prefix groups found in cache");
- }
- else {
- # groups not cached or changed
- debug(2, "$prefix groups not found in cache");
-
- # connect to database, use all data_sources until the connect
- # succeeds
- my $connect;
- for (my $j = 0; $j <= $#data_sources; $j++) {
- if ($dbh = DBI->connect(
- $data_sources[$j],
- $usernames[$j],
- $passwords[$j]
- )) {
- $connect = 1;
- last;
- }
- }
- unless ($connect) {
- $r->log_reason(
- "$prefix db connect error with " .
- "$Attr->{data_source}",
- $r->uri
- );
- return MP2 ? Apache2::Const::SERVER_ERROR() :
- Apache::Constants::SERVER_ERROR();
- }
-
- # generate statement
- my $user_sent_quoted = $dbh->quote($user_sent);
- my $select = "SELECT $Attr->{grp_field}";
- my $from = ($Attr->{grp_table}) ?
- "FROM $Attr->{grp_table}" : "FROM $Attr->{pwd_table}";
- my $where = ($Attr->{uidcasesensitive} eq "off") ?
- "WHERE lower($Attr->{uid_field}) =" :
- "WHERE $Attr->{uid_field} =";
- my $compare = ($Attr->{placeholder} eq "on") ?
- "?" : "$user_sent_quoted";
- my $statement = "$select $from $where $compare";
- $statement .= " AND $Attr->{grp_whereclause}"
- if ($Attr->{grp_whereclause});
-
- debug(2, "$prefix statement: $statement");
-
- # prepare statement
- my $sth;
- unless ($sth = $dbh->prepare($statement)) {
- $r->log_reason(
- "can not prepare statement: $DBI::errstr",
- $r->uri
- );
- $dbh->disconnect;
- return MP2 ? Apache2::Const::SERVER_ERROR() :
- Apache::Constants::SERVER_ERROR();
- }
-
- # execute statement
- my $rv;
- unless ($rv = ($Attr->{placeholder} eq "on") ?
- $sth->execute($user_sent) : $sth->execute) {
- $r->log_reason(
- "can not execute statement: $DBI::errstr",
- $r->uri
- );
- $dbh->disconnect;
- return MP2 ? Apache2::Const::SERVER_ERROR() :
- Apache::Constants::SERVER_ERROR();
- }
-
- # fetch result and build a group-list
- # strip trailing blanks for fixed-length data-type
- while (my $group = $sth->fetchrow_array) {
- $group =~ s/ +$//;
- $groups .= "$group,";
- }
- chop $groups if $groups;
-
- $sth->finish;
- $dbh->disconnect;
- }
-
- $r->subprocess_env(REMOTE_GROUPS => $groups);
- debug(2, "$prefix groups = >$groups<\n");
-
- # skip through the required groups until the first matches
- REQUIRE_2:
- foreach my $group_required (split /\s+/, $group_requirements) {
- foreach my $group (split(/,/, $groups)) {
- # check group
- if ($group_required eq $group) {
- $group_result = MP2 ? Apache2::Const::OK() :
- Apache::Constants::OK();
- $r->subprocess_env(REMOTE_GROUP => $group);
-
- debug(
- 2,
- "$prefix user $user_sent: group_result = OK " .
- "for >$group<"
- );
-
- # update timestamp and cache userid/groups if
- # CacheTime is configured
- if ($CacheTime) { # do we use the cache ?
- if ($SHMID) { # do we keep the cache in shared memory ?
- semop($SEMID, $obtain_lock)
- or warn "$prefix semop failed \n";
- shmread($SHMID, $Cache, 0, $SHMSIZE)
- or warn "$prefix shmread failed \n";
- substr($Cache, index($Cache, "\0")) = '';
- }
-
- # update timestamp and groups
- my $now = time;
- # entry must exists from authentication
- $Cache =~ s/$ID$;\d+$;(.*)$;.*\n/$ID$;$now$;$1$;$groups\n/;
- if ($SHMID) { # write cache to shared memory
- shmwrite($SHMID, $Cache, 0, $SHMSIZE)
- or warn "$prefix shmwrite failed \n";
- semop($SEMID, $release_lock)
- or warn "$prefix semop failed \n";
- }
- }
- last REQUIRE_2;
- }
- }
- }
- }
-
- # check the results of the requirement checks
- if ($Attr->{authoritative} eq 'on' &&
- (
- $user_result != (MP2 ?
- Apache2::Const::OK() :
- Apache::Constants::OK())
- )
- && (
- $group_result != (MP2 ? Apache2::Const::OK() :
- Apache::Constants::OK())
- )
- ) {
- my $reason;
- if ($user_result == (MP2 ? Apache2::Const::AUTH_REQUIRED() :
- Apache::Constants::AUTH_REQUIRED())) {
- $reason .= " USER";
- }
- if ($group_result == (MP2 ? Apache2::Const::AUTH_REQUIRED() :
- Apache::Constants::AUTH_REQUIRED())) {
- $reason .= " GROUP";
- }
- $r->log_reason(
- "DBI-Authoritative: Access denied on $reason rule(s)",
- $r->uri
- );
-
- if ($authz_denied == (MP2 ? Apache2::Const::AUTH_REQUIRED() :
- Apache::Constants::AUTH_REQUIRED())) {
- $r->note_basic_auth_failure;
- }
-
- return $authz_denied;
- }
-
- # return OK if authorization was successful
- my $success = MP2 ? Apache2::Const::OK() :
- Apache::Constants::OK();
- my $declined = MP2 ? Apache2::Const::DECLINED() :
- Apache::Constants::DECLINED();
-
- if (
- ($user_result != $declined && $user_result == $success)
- ||
- ($group_result != $declined && $group_result == $success)
- ) {
- debug(2, "$prefix return OK");
- return MP2 ? Apache2::Const::OK() : Apache::Constants::OK();
+ my $conf = config_request_load($r);
+ debug($r, DEBUG_REQ, "prefix not configured, DECLINED"),
+ return _declined() unless config_uri_configured($conf);
+
+ my $reqs = config_ht_access_parse($r);
+ unless ($reqs->{rules}) {
+ logr(
+ $r,
+ "$user_sent denied, no rules specified (DBI-Authoritative)"
+ );
+ $r->note_basic_auth_failure;
+ return _auth_required();
}
- # otherwise fall through
- debug(2, "$prefix fall through, return DECLINED");
- return MP2 ? Apache2::Const::DECLINED() : Apache::Constants::DECLINED();
-}
-
-sub dec2hex {
- my $dec = shift;
-
- return sprintf("%lx", $dec);
-}
-
-# The PerlChildInitHandler initializes the shared memory segment (first child)
-# or increments the child counter.
-# Note: this handler runs in every child server, but not in the main server.
-# create (or re-use existing) semaphore set
-sub childinit {
-
- my $prefix = "$$ Apache::AuthDBI PerlChildInitHandler";
-
- my $SHMKEY_hex = dec2hex($SHMKEY);
-
- debug(
- 2,
- "$prefix SHMProjID = >$SHMPROJID< Shared Memory Key >$SHMKEY " .
- "Decimal - $SHMKEY_hex Hex<"
- );
-
- $SEMID = semget(
- $SHMKEY,
- 1,
- IPC::SysV::IPC_CREAT() |
- IPC::SysV::S_IRUSR() |
- IPC::SysV::S_IWUSR()
- );
- unless (defined $SEMID) {
- warn "$prefix semget failed - SHMKEY $SHMKEY - Error $!\n";
- if (uc chomp $! eq 'PERMISSION DENIED') {
- warn " $prefix Read/Write Permission Denied to Shared Memory Array.\n";
- warn " $prefix Use ipcs -s to list semaphores and look for " .
- "$SHMKEY_hex. If found, shutdown Apache and use ipcrm sem " .
- "$SHMKEY_hex to remove the colliding (and hopefully " .
- "unused) semaphore. See documentation for setProjID " .
- "for more information. \n";
- }
+ my ($groups, $status) = db_groups_get($r, $conf, $user_sent);
+ return $status if $status;
- return;
+ my ($match) = grp_match_any($r, $user_sent, $reqs, $groups);
+ unless ($match) {
+ logr("$user_sent: not in any allowed groups");
+ $r->note_basic_auth_failure;
+ return _auth_required();
}
- # create (or re-use existing) shared memory segment
- $SHMID = shmget(
- $SHMKEY,
- $SHMSIZE,
- IPC::SysV::IPC_CREAT() |
- IPC::SysV::S_IRUSR() |
- IPC::SysV::S_IWUSR()
- );
- unless (defined $SHMID) {
- warn "$prefix shmget failed - Error $!\n";
- return;
- }
+ debug($r, DEBUG_REQ, "OK");
- # make ids accessible to other handlers
- $ENV{AUTH_SEMID} = $SEMID;
- $ENV{AUTH_SHMID} = $SHMID;
-
- # read shared memory, increment child count and write shared memory
- # segment
- semop($SEMID, $obtain_lock) or warn "$prefix semop failed \n";
- shmread($SHMID, $Cache, 0, $SHMSIZE)
- or warn "$prefix shmread failed \n";
- substr($Cache, index($Cache, "\0")) = '';
-
- # segment already exists (eg start of additional server)
- my $child_count_new = 1;
- if ($Cache =~ /^(\d+)$;(\d+)\n/) {
- my $time_stamp = $1;
- my $child_count = $2;
- $child_count_new = $child_count + 1;
- $Cache =~ s/^$time_stamp$;$child_count\n/$time_stamp$;$child_count_new\n/;
- }
- else {
- # first child => initialize segment
- $Cache = time . "$;$child_count_new\n";
- }
- debug(2, "$prefix child count = $child_count_new");
+ return _ok();
+}
- shmwrite($SHMID, $Cache, 0, $SHMSIZE)
- or warn "$prefix shmwrite failed \n";
- semop($SEMID, $release_lock) or warn "$prefix semop failed \n";
+sub childint {
- 1;
}
-# The PerlChildExitHandler decrements the child count or destroys the shared
-# memory segment upon server shutdown, which is defined by the exit of the
-# last child.
-# Note: this handler runs in every child server, but not in the main server.
sub childexit {
- my $prefix = "$$ Apache::AuthDBI PerlChildExitHandler";
-
- # read Cache from shared memory, decrement child count and exit or write
- #Cache to shared memory
- semop($SEMID, $obtain_lock) or warn "$prefix semop failed \n";
- shmread($SHMID, $Cache, 0, $SHMSIZE)
- or warn "$prefix shmread failed \n";
- substr($Cache, index($Cache, "\0")) = '';
- $Cache =~ /^(\d+)$;(\d+)\n/;
-
- my $time_stamp = $1;
- my $child_count = $2;
- my $child_count_new = $child_count - 1;
- if ($child_count_new) {
- debug(2, "$prefix child count = $child_count");
-
- # write Cache into shared memory
- $Cache =~ s/^$time_stamp$;$child_count\n/$time_stamp$;$child_count_new\n/;
- shmwrite($SHMID, $Cache, 0, $SHMSIZE)
- or warn "$prefix shmwrite failed \n";
- semop($SEMID, $release_lock) or warn "$prefix semop failed \n";
- }
- else {
- # last child
- # remove shared memory segment and semaphore set
- debug(
- 2,
- "$prefix child count = $child_count, remove shared memory " .
- "$SHMID and semaphore $SEMID"
- );
- shmctl($SHMID, IPC::SysV::IPC_RMID(), 0)
- or warn "$prefix shmctl failed \n";
- semctl($SEMID, 0, IPC::SysV::IPC_RMID(), 0)
- or warn "$prefix semctl failed \n";
- }
-
- 1;
}
-# The PerlCleanupHandler skips through the cache and deletes any outdated
-# entry.
-# Note: this handler runs after the response has been sent to the client.
sub cleanup {
- my $prefix = "$$ Apache::AuthDBI PerlCleanupHandler";
- debug(2, "$prefix");
-
- # do we keep the cache in shared memory ?
- my $now = time;
- if ($SHMID) {
- semop($SEMID, $obtain_lock) or warn "$prefix semop failed \n";
- shmread($SHMID, $Cache, 0, $SHMSIZE)
- or warn "$prefix shmread failed \n";
- substr($Cache, index($Cache, "\0")) = '';
- }
-
- # initialize timestamp for CleanupHandler
- my $newCache = "$now$;";
- my ($time_stamp, $child_count);
- foreach my $record (split(/\n/, $Cache)) {
- # first record: timestamp of CleanupHandler and child count
- if (!$time_stamp) {
- ($time_stamp, $child_count) = split /$;/, $record;
- $newCache .= "$child_count\n";
- next;
- }
- my ($id, $last_access, $passwd, $groups) = split /$;/, $record;
- my $diff = $now - $last_access;
- if ($diff >= $CacheTime) {
- debug(2, "$prefix delete >$id<, last access $diff s before");
- }
- else {
- debug(2, "$prefix keep >$id<, last access $diff s before");
- $newCache .= "$id$;$now$;$passwd$;$groups\n";
- }
- }
-
- # write Cache to shared memory
- $Cache = $newCache;
- if ($SHMID) {
- shmwrite($SHMID, $Cache, 0, $SHMSIZE)
- or warn "$prefix shmwrite failed \n";
- semop($SEMID, $release_lock) or warn "$prefix semop failed \n";
- }
-
- 1;
}
-# Added 06-14-2005 - KAM - Returns SHA1 digest - Modified from PerlCMS' more
-# generic routine to remove IO::File requirement
-sub SHA1_digest {
- my %params = @_;
-
- my $prefix = "$$ Apache::AuthDBI SHA1_digest";
- debug(2, $prefix);
+sub Log {
+ my $r = shift;
- $params{'format'} ||= "base64";
+ my $conf = config_request_load($r);
+ return _declined() unless config_log_configured($conf);
- my $sha1 = Digest::SHA1->new();
+ my ($dbh, $status) = dbh_get($r, $conf);
+ return $status if $status;
- if ($params{'text'} ne '') {
- $sha1->add($params{'text'});
- }
- else {
- return -1;
- }
+ my $user_sent =
+ $conf->{uidcasesensitivie} =~ /on/i ? lc($r->user) : $r->user;
- if ($params{'format'} =~ /base64/i) {
- return $sha1->b64digest;
- }
- elsif ($params{'format'} =~ /hex/i) {
- return $sha1->hexdigest;
- }
- elsif ($params{'format'} =~ /binary/i) {
- return $sha1->binary;
- }
+ my $sql = sql_log_update($r, $conf);
+ eval {
+ $dbh->do($sql, \%db_attrs, ($conf->{log_string}, $user_sent));
+ };
+ return _server_error() if $@;
- -1;
+ return _ok();
}
-# Added 06-20-2005 - KAM - Returns MD5 digest - Modified from PerlCMS' more
-# generic routine to remove IO::File requirement
-sub MD5_digest {
- my %params = @_;
+###########################################################################
+## #
+## Cache #
+## #
+###########################################################################
- my $prefix = "$$ Apache::AuthDBI MD5_digest";
- debug(2, $prefix);
+###########################################################################
+## #
+## Crypto #
+## #
+###########################################################################
+sub crypt_pws_get {
+ my ($r, $conf, $user_sent, $pw_sent) = @_;
- $params{'format'} ||= "hex";
+ my $m = $conf->{encryption_method};
- my $md5 = Digest::MD5->new();
+ my $salt = $conf->{encryption_salt} =~ /userid/i ?
+ $user_sent : $pw_sent;
- if ($params{'text'} ne '') {
- $md5->add($params{'text'});
- }
- else {
- return -1;
- }
+ my $crtyped = {};
+ $crypted->{$pw_sent} = 'plain'
+ if $m =~ /plain/i;
+ $crypted->{crypt_sha1hex($r, $pw_sent)} = 'sha1hex'
+ if $m =~ /sha1hex/i;
+ $crypted->{crypt_md5($r, $pw_sent)} = 'md5'
+ if $m =~ /md5/i;
+ $crypted->{crypt_crypt($r, $pw_sent, $salt)} = 'crypt'
+ if $m =~ /crypt/i;
- if ($params{'format'} =~ /base64/i) {
- return $md5->b64digest;
- }
- elsif ($params{'format'} =~ /hex/i) {
- return $md5->hexdigest;
- }
- elsif ($params{'format'} =~ /binary/i) {
- return $md5->digest;
- }
+ debug($r, DEBUG_PW, (scalar keys%$crypted) . " encryptions to check");
- -1;
+ return $crypted;
}
-1;
-
-__END__
-
-=head1 NAME
-
-Apache::AuthDBI - Authentication and Authorization via Perl's DBI
-
-=head1 SYNOPSIS
-
- # Configuration in httpd.conf or startup.pl:
-
- PerlModule Apache::AuthDBI
-
- # Authentication and Authorization in .htaccess:
+sub crypt_sha1hex {
+ my ($r, $pw_sent) = @_;
- AuthName DBI
- AuthType Basic
-
- PerlAuthenHandler Apache::AuthDBI::authen
- PerlAuthzHandler Apache::AuthDBI::authz
-
- PerlSetVar Auth_DBI_data_source dbi:driver:dsn
- PerlSetVar Auth_DBI_username db_username
- PerlSetVar Auth_DBI_password db_password
- #DBI->connect($data_source, $username, $password)
-
- PerlSetVar Auth_DBI_pwd_table users
- PerlSetVar Auth_DBI_uid_field username
- PerlSetVar Auth_DBI_pwd_field password
- # authentication: SELECT pwd_field FROM pwd_table WHERE uid_field=$user
- PerlSetVar Auth_DBI_grp_field groupname
- # authorization: SELECT grp_field FROM pwd_table WHERE uid_field=$user
-
- require valid-user
- require user user_1 user_2 ...
- require group group_1 group_2 ...
-
-The AuthType is limited to Basic. You may use one or more valid require lines.
-For a single require line with the requirement 'valid-user' or with the
-requirements 'user user_1 user_2 ...' it is sufficient to use only the
-authentication handler.
-
-=head1 DESCRIPTION
-
-This module allows authentication and authorization against a database
-using Perl's DBI. For supported DBI drivers see:
-
- http://dbi.perl.org/
-
-Authentication:
-
-For the given username the password is looked up in the cache. If the cache
-is not configured or if the user is not found in the cache, or if the given
-password does not match the cached password, it is requested from the database.
-
-If the username does not exist and the authoritative directive is set to 'on',
-the request is rejected. If the authoritative directive is set to 'off', the
-control is passed on to next module in line.
-
-If the password from the database for the given username is empty and the
-nopasswd directive is set to 'off', the request is rejected. If the nopasswd
-directive is set to 'on', any password is accepted.
+ require Digest::SHA1;
+ my $sha1 = Digest::SHA1->new();
-Finally the passwords (multiple passwords per userid are allowed) are
-retrieved from the database. The result is put into the environment variable
-REMOTE_PASSWORDS. Then it is compared to the password given. If the encrypted
-directive is set to 'on', the given password is encrypted using perl's crypt()
-function before comparison. If the encrypted directive is set to 'off' the
-plain-text passwords are compared.
+ return -1 if $pw_sent eq '';
-If this comparison fails the request is rejected, otherwise the request is
-accepted and the password is put into the environment variable REMOTE_PASSWORD.
+ $sha1->add($pw_sent);
-The SQL-select used for retrieving the passwords is as follows:
+ return $sha1->hexdigest;
+}
- SELECT pwd_field FROM pwd_table WHERE uid_field = user
+sub crypt_md5 {
+ my ($r, $pw_sent) = @_;
-If a pwd_whereclause exists, it is appended to the SQL-select.
+ require Digest::MD5;
+ my $md5 = Digest::MD5->new();
-This module supports in addition a simple kind of logging mechanism. Whenever
-the handler is called and a log_string is configured, the log_field will be
-updated with the log_string. As log_string - depending upon the database -
-macros like TODAY can be used.
+ return -1 if $pw_sent eq '';
-The SQL-select used for the logging mechanism is as follows:
+ $md5->add($pw_sent);
- UPDATE pwd_table SET log_field = log_string WHERE uid_field = user
+ return $md5->hexdigest();
+}
-Authorization:
+sub crypt_crypt {
+ my ($r, $pw_sent, $salt) = @_;
-When the authorization handler is called, the authentication has already been
-done. This means, that the given username/password has been validated.
+ return crypt($pw_sent, $salt);
+}
-The handler analyzes and processes the requirements line by line. The request
-is accepted if the first requirement is fulfilled.
+###########################################################################
+## #
+## SHM/SEM #
+## #
+###########################################################################
-In case of 'valid-user' the request is accepted.
+##############################################################################
+## #
+## Config #
+## #
+##############################################################################
+sub config_request_load {
+ my $r = shift;
-In case of one or more user-names, they are compared with the given user-name
-until the first match.
+ my $conf = ();
-In case of one or more group-names, all groups of the given username are
-looked up in the cache. If the cache is not configured or if the user is not
-found in the cache, or if the requested group does not match the cached group,
-the groups are requested from the database. A comma separated list of all
-these groups is put into the environment variable REMOTE_GROUPS. Then these
-groups are compared with the required groups until the first match.
+ return $Cache_Conf->{$r->uri} if exists $Cache_Conf->{$r->uri};
-If there is no match and the authoritative directive is set to 'on' the
-request is rejected.
+ # get configuration
+ while (my ($key, $val) = each %$Default_Config) {
+ $val = $r->dir_config($key) || $val;
+ $key =~ s/^Auth_DBI_//;
+ $conf->{$key} = $val;
-In case the authorization succeeds, the environment variable REMOTE_GROUP is
-set to the group name, which can be used by user scripts without accessing
-the database again.
+ debug($r, DEBUG_CONF, sprintf("Config{ %-16s } = %s", $key, $val));
+ }
-The SQL-select used for retrieving the groups is as follows (depending upon
-the existence of a grp_table):
+ $conf->{data_source} = [split /~/, $conf->{data_source}];
+ $conf->{username} = [split /~/, $conf->{username}];
+ $conf->{password} = [split /~/, $conf->{password}];
- SELECT grp_field FROM pwd_table WHERE uid_field = user
- SELECT grp_field FROM grp_table WHERE uid_field = user
+ # use ENV{DBI_DSN} if not defined
+ $conf->{data_sources}->[0] = '' unless $conf->{data_sources}->[0];
-This way the group-information can either be held in the main users table, or
-in an extra table, if there is an m:n relationship between users and groups.
-From all selected groups a comma-separated list is build, which is compared
-with the required groups. If you don't like normalized group records you can
-put such a comma-separated list of groups (no spaces) into the grp_field
-instead of single groups.
+ $Cache_Conf->{$r->uri} = $conf;
-If a grp_whereclause exists, it is appended to the SQL-select.
+ return $conf;
+}
-Cache:
+sub config_ht_access_parse {
+ my $r = shift;
-The module maintains an optional cash for all passwords/groups. See the
-method setCacheTime(n) on how to enable the cache. Every server has it's
-own cache. Optionally the cache can be put into a shared memory segment,
-so that it can be shared among all servers. See the CONFIGURATION section
-on how to enable the usage of shared memory.
+ return $Cache_Reqs->{$r->uri} if exists $Cache_Reqs->{$r->uri};
-In order to prevent the cache from growing indefinitely a CleanupHandler can
-be initialized, which skips through the cache and deletes all outdated entries.
-This can be done once per request after sending the response, hence without
-slowing down response time to the client. The minimum time between two
-successive runs of the CleanupHandler is configurable (see the CONFIGURATION
-section). The default is 0, which runs the CleanupHandler after every request.
+ my $reqs = {
+ rules => 0,
+ valid_user => 0,
+ users => [].
+ groups => [],
+ };
-=head1 LIST OF TOKENS
+ my $aref = $r->requires;
+ foreach my $href (@$aref) {
+ $reqs->{rules} ||= 1;
-=item * Auth_DBI_data_source (Authentication and Authorization)
+ while (my ($k, $v) = each %href) {
+ last if $k eq 'requirement';
+ }
-The data_source value has the syntax 'dbi:driver:dsn'. This parameter is
-passed to the database driver for processing during connect. The data_source
-parameter (as well as the username and the password parameters) may be a
-tilde ('~') separated list of several data_sources. All of these triples will
-be used until a successful connect is made. This way several backup-servers
-can be configured. if you want to use the environment variable DBI_DSN
-instead of a data_source, do not specify this parameter at all.
+ $v =~ s/^\s*require\s+//;
-=item * Auth_DBI_username (Authentication and Authorization)
+ if ($v =~ s/^user\s+//g) {
+ push @${$reqs->{users}}, split /\s+/, $v;
+ }
+ elsif ($v =~ s/^group\s+//g) {
+ push @${reqs->{groups}}, split /\s+/, $v;
+ }
+ elsif ($v =~ /valid-user/) {
+ $reqs->{valid_user} = 1;
+ }
+ else {
+ error($r, "Invalid directive line $k => $v");
+ }
+ }
-The username argument is passed to the database driver for processing during
-connect. This parameter may be a tilde ('~') separated list.
-See the data_source parameter above for the usage of a list.
+ debug($r, DEBUG_CONF, "valid-user: $reqs->{valid_user}");
+ debug($r, DEBUG_CONF, "users: " . join(',', @{$reqs->{users}}));
+ debug($r, DEBUG_CONF, "groups: " . join(',', @{$reqs->{groups}}));
-=item * Auth_DBI_password (Authentication and Authorization)
+ $Cache_Reqs->{$r->uri} = $reqs;
-The password argument is passed to the database driver for processing during
-connect. This parameter may be a tilde ('~') separated list.
-See the data_source parameter above for the usage of a list.
+ return $reqs;
+}
-=item * Auth_DBI_pwd_table (Authentication and Authorization)
+sub config_uri_configured {
+ return $_[0]->{pwd_table} && $_[0]->{uid_field} && $_[0]->{pwd_field}
+}
-Contains at least the fields with the username and the (possibly encrypted)
-password. The username should be unique.
+sub config_log_configured {
+ return $_[0]->{log_field} && $_[0]->{log_string}
+}
-=item * Auth_DBI_uid_field (Authentication and Authorization)
+##############################################################################
+## #
+## Constants Compat #
+## #
+##############################################################################
+sub _ok {
+ MP2 ? Apache2::Const::OK() : Apache::Constants::OK()
+}
-Field name containing the username in the Auth_DBI_pwd_table.
+sub _declined {
+ MP2 ? Apache2::Const::DECLINED() : Apache::Constants::DECLINED()
+}
-=item * Auth_DBI_pwd_field (Authentication only)
+sub _server_error {
+ MP2 ? Apache2::Const::SERVER_ERROR() :
+ Apache::Constants::SERVER_ERROR()
+}
-Field name containing the password in the Auth_DBI_pwd_table.
+sub _auth_required {
+ MP2 ? Apache2::Const::AUTH_REQUIRED() :
+ Apache::Constants::AUTH_REQUIRED()
+}
-=item * Auth_DBI_pwd_whereclause (Authentication only)
+sub _forbidden {
+ MP2 ? Apache2::Const::FORBIDDEN() : Apache::Constants::FORBIDDEN()
+}
-Use this option for specifying more constraints to the SQL-select.
+##############################################################################
+## #
+## Utility #
+## #
+##############################################################################
+sub dec2hex { return sprintf("%lx", shift) }
-=item * Auth_DBI_grp_table (Authorization only)
+sub logr { $_[0]->log_reason(prefix() . ": $_[1]", $_[0]->uri) }
+sub debug { $_[0]->log_reason(prefix() . ": $_[2]", $_[0]->uri) if $Debug & $_[1] }
+sub error { logr @_ }
-Contains at least the fields with the username and the groupname.
+sub cache_id {
+ my ($r, $conf) = @_;
-=item * Auth_DBI_grp_field (Authorization only)
+ my $ds_str = join '~', @{$conf->{data_sources}};
-Field-name containing the groupname in the Auth_DBI_grp_table.
+ my $id = join ',',
+ $r->user, $ds_str, $conf->{pwd_table}, $conf->{uid_field};
-=item * Auth_DBI_grp_whereclause (Authorization only)
+ debug($r, DEBUG_CACHE, "id: $id");
-Use this option for specifying more constraints to the SQL-select.
+ return $id;
+}
-=item * Auth_DBI_log_field (Authentication only)
+## Less pw in db then encrypted methods probably
+## O(@$pws_db+C)
+## short circuited
+sub pw_match_any {
+ my ($r, $user_sent, $pws_sent_crypted, $pws_db) = @_;
-Field name containing the log string in the Auth_DBI_pwd_table.
+ my $match = 0;
+ foreach my $pw_db (@$pws_db) {
+ if (exists $pws_sent_crypted->{$pw_db}) {
+ $match = 1;
+ debug(
+ $r
+ DEBUG_PW,
+ "[$user_sent]/[$pw_db] found in encryption " .
+ "[$pws_sent_crypted->{$pw_db}]"
+ );
+ $r->subprocess_env(REMOTE_PASSWORD => );
+ last;
+ }
+ }
-=item * Auth_DBI_log_string (Authentication only)
+ return $match;
+}
-String to update the Auth_DBI_log_field in the Auth_DBI_pwd_table. Depending
-upon the database this can be a macro like 'TODAY'.
+sub grp_match_any {
+ my ($r, $user_sent, $reqs, $groups) = @_;
-=item * Auth_DBI_authoritative < on / off> (Authentication and Authorization)
+ my %rgs = map { $_ => 1 } @{$reqs->{group}};
-Default is 'on'. When set 'on', there is no fall-through to other
-authentication methods if the authentication check fails. When this directive
-is set to 'off', control is passed on to any other authentication modules. Be
-sure you know what you are doing when you decide to switch it off.
+ my $match = 0;
+ foreach my $group (@groups) {
+ if (exists $rgs->{$group}) {
+ $match = 1;
+ debug(
+ $r,
+ DEBUG_PW,
+ "[$user_sent] member of allowed group [$group]"
+ );
+ $r->subprocess_env(REMOTE_GROUP => $group);
+ last;
+ }
+ }
-=item * Auth_DBI_nopasswd < on / off > (Authentication only)
+ return $match;
+}
-Default is 'off'. When set 'on' the password comparison is skipped if the
-password retrieved from the database is empty, i.e. allow any password.
-This is 'off' by default to ensure that an empty Auth_DBI_pwd_field does not
-allow people to log in with a random password. Be sure you know what you are
-doing when you decide to switch it on.
+sub prefix {
-=item * Auth_DBI_encrypted < on / off > (Authentication only)
+ my ($package, $subroutine) = (caller(1))[0,3];
+ my $pid = $$;
-Default is 'on'. When set to 'on', the password retrieved from the database
-is assumed to be crypted. Hence the incoming password will be crypted before
-comparison. When this directive is set to 'off', the comparison is done
-directly with the plain-text entered password.
+ return "$pid $package $subroutine";
+}
-=item *
-Auth_DBI_encryption_method < sha1hex/md5hex/crypt > (Authentication only)
-Default is blank. When set to one or more encryption method, the password
-retrieved from the database is assumed to be crypted. Hence the incoming
-password will be crypted before comparison. The method supports falling
-back so specifying 'sha1hex/md5hex' would allow for a site that is upgrading
-to sha1 to support both methods. sha1 is the recommended method.
+##############################################################################
+## #
+## DB/SQL #
+## #
+##############################################################################
+sub db_pws_get {
+ my ($r, $conf, $user_sent) = @_;
-=item * Auth_DBI_encryption_salt < password / userid > (Authentication only)
+ my ($dbh, $status) = dbh_get($r, $conf);
+ return ([], $status) if $status;
-When crypting the given password AuthDBI uses per default the password
-selected from the database as salt. Setting this parameter to 'userid',
-the module uses the userid as salt.
+ my $pws = [];
+ my $sql = sql_pwd_get($r, $conf);
+ my $sth;
+ eval {
+ $sth = $dbh->prepare($sql);
+ $sth->execute($user_sent);
+ };
+ return ($pws, _server_error()) if $@;
-=item *
-Auth_DBI_uidcasesensitive < on / off > (Authentication and Authorization)
+ $sth->bind_columns(\my $pw);
+ while ($sth->fetch()) {
+ push @$pws, $pw;
+ }
+ $sth->finish();
-Default is 'on'. When set 'off', the entered userid is converted to lower case.
-Also the userid in the password select-statement is converted to lower case.
+ my $pw_str = join "$;", @$pws;
+ chop $pw_str;
+ debug($r, DEBUG_DB, "pws => [$pw_str]");
+ $r->subprocess_env(REMOTE_PASSWORDS => $pw_str);
-=item * Auth_DBI_pwdcasesensitive < on / off > (Authentication only)
+ return ($pws, $status);
+}
-Default is 'on'. When set 'off', the entered password is converted to lower
-case.
+sub db_groups_get {
+ my ($r, $conf, $user_sent) = @_;
-=item * Auth_DBI_placeholder < on / off > (Authentication and Authorization)
+ my ($dbh, $status) = dbh_get($r, $conf);
+ return ([], $status) if $status;
-Default is 'off'. When set 'on', the select statement is prepared using a
-placeholder for the username. This may result in improved performance for
-databases supporting this method.
+ my $grps = [];
+ my $sql = sql_grp_get($r, $conf);
+ my $sth;
+ eval {
+ $sth = $dbh->prepare($sql);
+ $sth->execute($user_sent);
+ };
+ return ($grps, _server_error()) if $@;
-=head1 CONFIGURATION
+ $sth->bind_columns(\my $grp);
+ while ($sth->fetch()) {
+ push @$grps, $grp;
+ }
+ $sth->finish();
-The module should be loaded upon startup of the Apache daemon.
-Add the following line to your httpd.conf:
+ my $grp_str = join "$;", @$grps;
+ chop $grp_str;
+ debug($r, DEBUG_DB, "grps => [$grp_str]");
+ $r->subprocess_env(REMOTE_GROUPS => $grp_str);
- PerlModule Apache::AuthDBI
+ return ($grps, $status);
+}
-A common usage is to load the module in a startup file via the PerlRequire
-directive. See eg/startup.pl for an example.
+sub dbh_get {
+ my ($r, $conf) = @_;
-There are three configurations which are server-specific and which can be done
-in a startup file:
+ my $ds = $conf->{data_sources};
+ my $us = $conf->{usernames};
+ my $ps = $conf->{password};
- Apache::AuthDBI->setCacheTime(0);
+ foreach my $i (0..$#@{$data_sources}) {
+ $dbh = DBI->connect($ds->[$i], $us->[$i], $ps->[$i], \%db_attrs);
+ last if $dbh;
+ }
-This configures the lifetime in seconds for the entries in the cache.
-Default is 0, which turns off the cache. When set to any value n > 0, the
-passwords/groups of all users will be cached for at least n seconds. After
-finishing the request, a special handler skips through the cache and deletes
-all outdated entries (entries, which are older than the CacheTime).
+ error($r, "none of " . join("\n", @$ds) . " usable")
+ unless $dbh;
- Apache::AuthDBI->setCleanupTime(-1);
+ return $dbh ? ($dbh, undef) : (undef, _server_error());
+}
-This configures the minimum time in seconds between two successive runs of the
-CleanupHandler, which deletes all outdated entries from the cache. The default
-is -1, which disables the CleanupHandler. Setting the interval to 0 runs the
-CleanupHandler after every request. For a heavily loaded server this should be
-set to a value, which reflects a compromise between scanning a large cache
-possibly containing many outdated entries and between running many times the
-CleanupHandler on a cache containing only few entries.
+sub sql_grp_select {
+ my ($r, $conf) = @_;
- Apache::AuthDBI->setProjID(1);
+ ## XXX: UID Case Comparisons
+ ## MySQL: doesn't do FBIs
+ ## MySQL: string types for ascii sets compare case insensitively
+ ## MySQL: string types for binary sets (UTF8, UTF16...) compare
+ ## btyes thus use case.
+ ## MySQL: only need lower()/lc for mysql binary sets, or not mysql
-This configures the project ID used to create a semaphore ID for shared memory.
-It can be set to any integer 1 to 255 or it will default to a value of 1.
+ my $ignore_u = $conf->{uidcasesensitive} =~ /on/i ? 0 : 1;
-NOTE: This must be set prior to calling initIPC.
+ my $table = $conf->{grp_table} ?
+ $conf->{grp_table} : $conf->{pwd_table};
+ my $uid_field = $ignore_u ?
+ "$conf->{uid_field}" : "lower($conf->{uid_field})";
+ my $extra = $conf->{grp_whereclause} ?
+ "AND $conf->{grp_whereclause}" : "";
-If you are running multiple instances of Apache on the same server\
-(for example, Apache1 and Apache2), you may not want (or be able) to use
-shared memory between them. In this case, use a different project ID on
-each server.
+ my $sql =<<END_SQL;
+SELECT $conf->{grp_field}
+FROM $table
+WHERE $uid_field = ?
+$extra
+END_SQL
-If you are reading this because you suspect you have a permission issue or a
-collision with a semaphore, use 'ipcs -s' to list semaphores and look for the
-Semaphore ID from the apache error log. If found, shutdown Apache (all of
-them) and use 'ipcrm sem <semaphore key>' to remove the colliding
-(and hopefully unused) semaphore.
+ debug($r, DEBUG_SQL, $sql);
-You may also want to remove any orphaned shared memory segments by using
-'ipcs -m' and removing the orphans with ipcrm shm <shared memory id>.
+ return $sql;
+}
- Apache::AuthDBI->initIPC(50000);
+sub sql_pwd_select {
+ my ($r, $conf) = @_;
-This enables the usage of shared memory for the cache. Instead of every server
-maintaining it's own cache, all servers have access to a common cache. This
-should minimize the database load considerably for sites running many servers.
-The number indicates the size of the shared memory segment in bytes. This size
-is fixed, there is no dynamic allocation of more segments. As a rule of thumb
-multiply the estimated maximum number of simultaneously cached users by 100 to
-get a rough estimate of the needed size. Values below 500 will be overwritten
-with the default 50000.
+ ## XXX: UID Case Comparisons
+ ## MySQL: doesn't do FBIs
+ ## MySQL: string types for ascii sets compare case insensitively
+ ## MySQL: string types for binary sets (UTF8, UTF16...) compare
+ ## btyes thus use case.
+ ## MySQL: only need lower()/lc for mysql binary sets, or not mysql
-To enable debugging the variable $Apache::AuthDBI::DEBUG must be set. This
-can either be done in startup.pl or in the user script. Setting the variable
-to 1, just reports about a cache miss. Setting the variable to 2 enables full
-debug output.
+ my $ignore_u = $conf->{uidcasesensitive} =~ /on/i ? 0 : 1;
+ my $ignore_p = $conf->{pwdcasesensitive} =~ /on/i ? 0 : 1;
-=head1 PREREQUISITES
+ my $table = $conf->{pwd_table} ?
+ $conf->{pwd_table} : $conf->{pwd_table};
+ my $uid_field = $ignore_u ?
+ "$conf->{uid_field}" : "lower($conf->{uid_field})";
+ my $pwd_field = $ignore_p ?
+ "$conf->{pwd_field}" : "lower($conf->{pwd_field})";
+ my $extra = $conf->{pwd_whereclause} ?
+ "AND $conf->{pwd_whereclause}" : "";
-=head2 MOD_PERL 2.0
+ my $sql =<<END_SQL;
+SELECT $pwd_field
+FROM $table
+WHERE $uid_field = ?
+$extra
+END_SQL
-Apache::DBI version 0.96 and should work under mod_perl 2.0 RC5 and later
-with httpd 2.0.49 and later.
+ debug($r, DEBUG_SQL, $sql);
-Apache::DBI versions less than 1.00 are NO longer supported. Additionally,
-mod_perl versions less then 2.0.0 are NO longer supported.
+ return $sql;
+}
-=head2 MOD_PERL 1.0
-Note that this module needs mod_perl-1.08 or higher, apache_1.3.0 or higher
-and that mod_perl needs to be configured with the appropriate call-back hooks:
+sub sql_log_update {
+ my ($r, $conf) = @_;
- PERL_AUTHEN=1 PERL_AUTHZ=1 PERL_CLEANUP=1 PERL_STACKED_HANDLERS=1
+ ## XXX: UID Case Comparisons
+ ## MySQL: doesn't do FBIs
+ ## MySQL: string types for ascii sets compare case insensitively
+ ## MySQL: string types for binary sets (UTF8, UTF16...) compare
+ ## btyes thus use case.
+ ## MySQL: only need lower()/lc for mysql binary sets, or not mysql
-Apache::DBI v0.94 was the last version before dual mod_perl 2.x support was begun.
-It still recommened that you use the latest version of Apache::DBI because Apache::DBI
-versions less than 1.00 are NO longer supported.
+ my $ignore_u = $conf->{uidcasesensitive} =~ /on/i ? 0 : 1;
-=head1 SECURITY
+ my $uid_field = $ignore_u ?
+ "$conf->{uid_field}" : "lower($conf->{uid_field})";
-In some cases it is more secure not to put the username and the password in
-the .htaccess file. The following example shows a solution to this problem:
+ my $sql = <<END_SQL;
+UPDATE $conf->{pwd_table}
+SET
+$conf->{log_field} = ?
+WHERE $uid_field = ?
+END_SQL
-httpd.conf:
+ debug($r, DEBUG_SQL, $sql);
- <Perl>
- my($uid,$pwd) = My::dbi_pwd_fetch();
- $Location{'/foo/bar'}->{PerlSetVar} = [
- [ Auth_DBI_username => $uid ],
- [ Auth_DBI_password => $pwd ],
- ];
- </Perl>
+ return $sql;
+}
-=head1 SEE ALSO
-L<Apache>, L<mod_perl>, L<DBI>
+1;
-=head1 AUTHORS
+__END__
-=item *
-Apache::AuthDBI by Edmund Mergl; now maintained and supported by the
-modperl mailinglist, subscribe by sending mail to
-modperl-subscribe@perl.apache.org.
+=head1 NAME
-=item *
-mod_perl by Doug MacEachern.
+Apache::AuthDBI - Authentication and Authorization via Perl's DBI
-=item *
-DBI by Tim Bunce <db...@perl.org>
+=head1 SYNOPSIS
=head1 COPYRIGHT