# $Id$
package Apache::AuthDBI;
### core
use strict;
use warnings FATAL => 'all';
use Carp;

### 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);
  if (MP2) {
	require Apache2::Access;
    require Apache2::Const;
    require Apache2::RequestRec;
    require Apache2::Log;
    import Apache2::Const @constants;
  }
  else {
    require Apache::Constants;
    import Apache::Constants @constants;
  }
}

### Version
our $VERSION = '1.08-dev';

### 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

sub authen {
    my $r = shift;

    debug($r, DEBUG_REQ, $r->as_string);

    return _ok() unless $r->is_initial_req;

    my ($res, $pw_sent) = $r->get_basic_auth_pw;
    debug($r, DEBUG_REQ, "res => [$rew], pw_sent => [$pw_sent]");
    return $res if $res;

    my $conf = config_request_load($r);
    debug($r, DEBUG_REQ, "prefix not configured, DECLINED"),
        return _declined() unless config_uri_configured($conf);

    my $user_sent =
        $conf->{uidcasesensitive} =~ /on/i ? lc($r->user) : $r->user;

    my ($pws_db, $status) = db_pws_get($r, $conf, $user_sent);
    return $status if $status;

    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 _auth_required();
        }
        else {
            return _declined();
        }

        ## blanket access
        $conf->{nopwasswd} =~ /on/i ? _ok() : _auth_required();
    }

    my ($pws_sent_crypted) =
        crypt_pws_get($r, $conf, $user_sent, $pw_sent);

    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 _auth_required();
    }

    debug($r, DEBUG_REQ, "OK");

    return _ok();
}

sub authz {
    my $r = shift;

    return _ok() unless $r->is_initial_req;

    my $user_sent = $r->user;

    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();
    }

    my ($groups, $status) = db_groups_get($r, $conf, $user_sent);
    return $status if $status;

    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();
    }

    debug($r, DEBUG_REQ, "OK");

    return _ok();
}

sub childint {

}

sub childexit {

}

sub cleanup {

}

sub Log {
    my $r = shift;

    my $conf = config_request_load($r);
    return _declined() unless config_log_configured($conf);

    my ($dbh, $status) = dbh_get($r, $conf);
    return $status if $status;

    my $user_sent =
        $conf->{uidcasesensitivie} =~ /on/i ? lc($r->user) : $r->user;

    my $sql = sql_log_update($r, $conf);
    eval {
        $dbh->do($sql, \%db_attrs, ($conf->{log_string}, $user_sent));
    };
    return _server_error() if $@;

    return _ok();
}

###########################################################################
##                                                                        #
##                                Cache                                   #
##                                                                        #
###########################################################################

###########################################################################
##                                                                        #
##                                Crypto                                  #
##                                                                        #
###########################################################################
sub crypt_pws_get {
    my ($r, $conf, $user_sent, $pw_sent) = @_;

    my $m = $conf->{encryption_method};

    my $salt = $conf->{encryption_salt} =~ /userid/i ?
        $user_sent : $pw_sent;

    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;

    debug($r, DEBUG_PW, (scalar keys%$crypted) . " encryptions to check");

    return $crypted;
}

sub crypt_sha1hex {
    my ($r, $pw_sent) = @_;

    require Digest::SHA1;
    my $sha1 = Digest::SHA1->new();

    return -1 if $pw_sent eq '';

    $sha1->add($pw_sent);

    return $sha1->hexdigest;
}

sub crypt_md5 {
    my ($r, $pw_sent) = @_;

    require Digest::MD5;
    my $md5 = Digest::MD5->new();

    return -1 if $pw_sent eq '';

    $md5->add($pw_sent);

    return $md5->hexdigest();
}

sub crypt_crypt {
    my ($r, $pw_sent, $salt) = @_;

    return crypt($pw_sent, $salt);
}

###########################################################################
##                                                                        #
##                                SHM/SEM                                 #
##                                                                        #
###########################################################################

##############################################################################
##                                                                           #
##                                Config                                     #
##                                                                           #
##############################################################################
sub config_request_load {
    my $r = shift;

    my $conf = ();

    return $Cache_Conf->{$r->uri} if exists $Cache_Conf->{$r->uri};

    # get configuration
    while (my ($key, $val) = each %$Default_Config) {
        $val = $r->dir_config($key) || $val;
        $key =~ s/^Auth_DBI_//;
        $conf->{$key} = $val;

        debug($r, DEBUG_CONF, sprintf("Config{ %-16s } = %s", $key, $val));
    }

    $conf->{data_source} = [split /~/, $conf->{data_source}];
    $conf->{username}    = [split /~/, $conf->{username}];
    $conf->{password}    = [split /~/, $conf->{password}];

    # use ENV{DBI_DSN} if not defined
    $conf->{data_sources}->[0] = '' unless $conf->{data_sources}->[0];

    $Cache_Conf->{$r->uri} = $conf;

    return $conf;
}

sub config_ht_access_parse {
    my $r = shift;

    return $Cache_Reqs->{$r->uri} if exists $Cache_Reqs->{$r->uri};

    my $reqs = {
                rules      => 0,
                valid_user => 0,
                users      => [].
                groups     => [],
               };

    my $aref = $r->requires;
    foreach my $href (@$aref) {
        $reqs->{rules} ||= 1;

        while (my ($k, $v) = each %href) {
            last if $k eq 'requirement';
        }

        $v =~ s/^\s*require\s+//;

        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");
        }
    }

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

    $Cache_Reqs->{$r->uri} = $reqs;

    return $reqs;
}

sub config_uri_configured {
    return $_[0]->{pwd_table} && $_[0]->{uid_field} && $_[0]->{pwd_field}
}

sub config_log_configured {
    return $_[0]->{log_field} && $_[0]->{log_string}
}

##############################################################################
##                                                                           #
##                           Constants Compat                                #
##                                                                           #
##############################################################################
sub _ok {
    MP2 ? Apache2::Const::OK() : Apache::Constants::OK()
}

sub _declined {
    MP2 ? Apache2::Const::DECLINED() : Apache::Constants::DECLINED()
}

sub _server_error  {
    MP2 ? Apache2::Const::SERVER_ERROR() :
        Apache::Constants::SERVER_ERROR()
}

sub _auth_required {
    MP2 ? Apache2::Const::AUTH_REQUIRED() :
        Apache::Constants::AUTH_REQUIRED()
}

sub _forbidden {
    MP2 ? Apache2::Const::FORBIDDEN() : Apache::Constants::FORBIDDEN()
}

##############################################################################
##                                                                           #
##                                Utility                                    #
##                                                                           #
##############################################################################
sub dec2hex { return sprintf("%lx", shift) }

sub logr  { $_[0]->log_reason(prefix() . ": $_[1]", $_[0]->uri) }
sub debug { $_[0]->log_reason(prefix() . ": $_[2]", $_[0]->uri) if $Debug & $_[1] }
sub error { logr @_ }

sub cache_id {
    my ($r, $conf) = @_;

    my $ds_str = join '~', @{$conf->{data_sources}};

    my $id = join ',',
        $r->user, $ds_str, $conf->{pwd_table}, $conf->{uid_field};

    debug($r, DEBUG_CACHE, "id: $id");

    return $id;
}

## 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) = @_;

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

    return $match;
}

sub grp_match_any {
    my ($r, $user_sent, $reqs, $groups) = @_;

    my %rgs = map { $_ => 1 } @{$reqs->{group}};

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

    return $match;
}

sub prefix {

    my ($package, $subroutine) = (caller(1))[0,3];
    my $pid = $$;

    return "$pid $package $subroutine";
}


##############################################################################
##                                                                           #
##                                DB/SQL                                     #
##                                                                           #
##############################################################################
sub db_pws_get {
    my ($r, $conf, $user_sent) = @_;

    my ($dbh, $status) = dbh_get($r, $conf);
    return ([], $status) if $status;

    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 $@;

    $sth->bind_columns(\my $pw);
    while ($sth->fetch()) {
        push @$pws, $pw;
    }
    $sth->finish();

    my $pw_str = join "$;", @$pws;
    chop $pw_str;
    debug($r, DEBUG_DB, "pws => [$pw_str]");
    $r->subprocess_env(REMOTE_PASSWORDS => $pw_str);

    return ($pws, $status);
}

sub db_groups_get {
    my ($r, $conf, $user_sent) = @_;

    my ($dbh, $status) = dbh_get($r, $conf);
    return ([], $status) if $status;

    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 $@;

    $sth->bind_columns(\my $grp);
    while ($sth->fetch()) {
        push @$grps, $grp;
    }
    $sth->finish();

    my $grp_str = join "$;", @$grps;
    chop $grp_str;
    debug($r, DEBUG_DB, "grps => [$grp_str]");
    $r->subprocess_env(REMOTE_GROUPS => $grp_str);

    return ($grps, $status);
}

sub dbh_get {
    my ($r, $conf) = @_;

    my $ds = $conf->{data_sources};
    my $us = $conf->{usernames};
    my $ps = $conf->{password};

    foreach my $i (0..$#@{$data_sources}) {
        $dbh = DBI->connect($ds->[$i], $us->[$i], $ps->[$i], \%db_attrs);
        last if $dbh;
    }

    error($r, "none of " . join("\n", @$ds) . " usable")
        unless $dbh;

    return $dbh ? ($dbh, undef) : (undef, _server_error());
}

sub sql_grp_select {
    my ($r, $conf) = @_;

    ## 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

    my $ignore_u = $conf->{uidcasesensitive} =~ /on/i ? 0 : 1;

    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}" : "";

    my $sql =<<END_SQL;
SELECT $conf->{grp_field}
FROM $table
WHERE $uid_field = ?
$extra
END_SQL

    debug($r, DEBUG_SQL, $sql);

    return $sql;
}

sub sql_pwd_select {
    my ($r, $conf) = @_;

    ## 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

    my $ignore_u = $conf->{uidcasesensitive} =~ /on/i ? 0 : 1;
    my $ignore_p = $conf->{pwdcasesensitive} =~ /on/i ? 0 : 1;

    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}" : "";

    my $sql =<<END_SQL;
SELECT $pwd_field
FROM $table
WHERE $uid_field = ?
$extra
END_SQL

    debug($r, DEBUG_SQL, $sql);

    return $sql;
}

sub sql_log_update {
    my ($r, $conf) = @_;

    ## 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

    my $ignore_u = $conf->{uidcasesensitive} =~ /on/i ? 0 : 1;

    my $uid_field  = $ignore_u ?
        "$conf->{uid_field}" : "lower($conf->{uid_field})";

    my $sql = <<END_SQL;
UPDATE $conf->{pwd_table}
SET
$conf->{log_field} = ?
WHERE $uid_field = ?
END_SQL

    debug($r, DEBUG_SQL, $sql);

    return $sql;
}



1;

__END__

=head1 NAME

Apache::AuthDBI - Authentication and Authorization via Perl's DBI

=head1 SYNOPSIS

=head1 COPYRIGHT

The Apache::AuthDBI module is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=cut
