view release on metacpan or  search on metacpan

lib/Apache2/AuthCookieDBI.pm  view on Meta::CPAN

# this order separated by dashes.

sub _now_year_month_day_hour_minute_second {
    return sprintf '%04d-%02d-%02d-%02d-%02d-%02d', Today_and_Now;
}

sub _check_password {
    my ( $class, $password, $crypted_password, $crypt_type ) = @_;
    return
        if not $crypted_password
        ;    # https://rt.cpan.org/Public/Bug/Display.html?id=62470

    my %password_checker = (
        'none' => sub { return $password eq $crypted_password; },
        'crypt' => sub {
            return crypt( $password, $crypted_password ) eq $crypted_password;
        },
        'md5' => sub { return md5_hex($password) eq $crypted_password; },
        'sha256' => sub {
            return Digest::SHA::sha256_hex($password) eq $crypted_password;
        },
        'sha384' => sub {
            return Digest::SHA::sha384_hex($password) eq $crypted_password;
        },
        'sha512' => sub {
            return Digest::SHA::sha512_hex($password) eq $crypted_password;
        },
    );
    return $password_checker{$crypt_type}->();
}

#-------------------------------------------------------------------------------
# _percent_encode -- Percent-encode (like URI encoding) any non-alphanumberics
# in the supplied string.

sub _percent_encode {
    my ($str) = @_;
    my $not_a_word = qr/ ( \W ) /x;
    $str =~ s/$not_a_word/ uc sprintf '%%%02x', ord $1 /xmeg;
    return $str;
}

#-------------------------------------------------------------------------------
# _percent_decode -- Percent-decode (like URI decoding) any %XX sequences in
# the supplied string.

sub _percent_decode {
    my ($str) = @_;
    my $percent_hex_string_regex = qr/ %([0-9a-fA-F]{2}) /x;
    $str =~ s/$percent_hex_string_regex/ pack( "c",hex( $1 ) ) /xmge;
    return $str;
}

#-------------------------------------------------------------------------------
# _dbi_connect -- Get a database handle.

sub _dbi_connect {
    my ( $class, $r, $config_hash ) = @_;
    Carp::confess('Failed to pass Apache request object') if not $r;

    my ( $pkg, $file, $line, $sub ) = caller(1);
    my $info_message = "${class}\t_dbi_connect called in $sub at line $line";
    $class->logger( $r, Apache2::Const::LOG_INFO, $info_message, undef,
        LOG_TYPE_SYSTEM, $r->uri );

    my %c = $config_hash ? %$config_hash : $class->_dbi_config_vars($r);

    my $auth_name = $r->auth_name;

    # get the crypted password from the users database for this user.
    my $dbh = DBI->connect_cached( $c{'DBI_DSN'}, $c{'DBI_User'},
        $c{'DBI_Password'} );
    if ( defined $dbh ) {
        my $info_message
            = "${class}\tconnect to $c{'DBI_DSN'} for auth realm $auth_name";
        $class->logger( $r, Apache2::Const::LOG_INFO, $info_message, undef,
            LOG_TYPE_SYSTEM, $r->uri );
        return $dbh;
    }
    else {
        my $error_message
            = "${class}\tcouldn't connect to $c{'DBI_DSN'} for auth realm $auth_name";
        $class->logger( $r, Apache2::Const::LOG_ERR, $error_message,
            LOG_TYPE_SYSTEM, undef, $r->uri );
        return;
    }
}

#-------------------------------------------------------------------------------
# _get_crypted_password -- Get the users' password from the database.

  sub _get_crypted_password {
    my ( $class, $r, $user, $config_hash ) = @_;
    my %c         = $config_hash ? %$config_hash : $class->_dbi_config_vars($r);
    my $dbh       = $class->_dbi_connect($r, \%c) || return;
    my $auth_name = $r->auth_name;

    if ( !$class->user_is_active( $r, $user, \%c ) ) {
        my $message
            = "${class}\tUser '$user' is not active for auth realm $auth_name.";
        $class->logger( $r, Apache2::Const::LOG_NOTICE, $message, $user,
            LOG_TYPE_AUTH, $r->uri );
        return;
    }

    my $crypted_password = EMPTY_STRING;

    my $PasswordField = $dbh->quote_identifier($c{'DBI_PasswordField'});
    my $UsersTable = $dbh->quote_identifier($c{'DBI_UsersTable'});
    my $UserField = $dbh->quote_identifier($c{'DBI_UserField'});

    my $sql_query = <<"SQL";
      SELECT $PasswordField
      FROM $UsersTable
      WHERE $UserField = ?
      AND ($PasswordField != ''
      AND $PasswordField IS NOT NULL)
SQL
    my $sth = $dbh->prepare_cached($sql_query);
    unless ( defined $sth ) {
        my $message = "${class}\tcouldn\'t prepare statement handle to $c{'DBI_DSN'} for auth realm $auth_name";

lib/Apache2/AuthCookieDBI.pm  view on Meta::CPAN

SQL

    my $sth = $dbh->prepare_cached($sql_query);
    $sth->execute($user);
    my ($user_active_setting) = $sth->fetchrow_array;
    $sth->finish();

    return $user_active_setting;
}

#-------------------------------------------------------------------------------

sub _get_expire_time {
    my $session_lifetime = shift;
    $session_lifetime = lc $session_lifetime;

    my $expire_time = EMPTY_STRING;

    if ( $session_lifetime eq 'forever' ) {
        $expire_time = '9999-01-01-01-01-01';

        # expire time in a zillion years if it's forever.
        return $expire_time;
    }

    my ( $deltaday, $deltahour, $deltaminute, $deltasecond )
        = split HYPHEN_REGEX, $session_lifetime;

    # Figure out the expire time.
    $expire_time = sprintf(
        '%04d-%02d-%02d-%02d-%02d-%02d',
        Add_Delta_DHMS( Today_and_Now, $deltaday, $deltahour,
            $deltaminute, $deltasecond
        )
    );
    return $expire_time;
}

sub logger {
    my ( $class, $r, $log_level, $message, $user, $log_type, @extra_args ) = @_;

    # $log_level should be an Apache constant, e.g. Apache2::Const::LOG_NOTICE

    # Sub-classes should override this method if they want to implent their
    # own logging strategy.
    #
    my @log_args = ( $message, @extra_args );

    my %apache_log_method_for_level = (
        Apache2::Const::LOG_DEBUG   => 'debug',
        Apache2::Const::LOG_INFO    => 'info',
        Apache2::Const::LOG_NOTICE  => 'notice',
        Apache2::Const::LOG_WARNING => 'warn',
        Apache2::Const::LOG_ERR     => 'error',
        Apache2::Const::LOG_CRIT    => 'crit',
        Apache2::Const::LOG_ALERT   => 'alert',
        Apache2::Const::LOG_EMERG   => 'emerg',
    );
    my $log_method = $apache_log_method_for_level{$log_level};
    if ( !$log_method ) {
        my ( $pkg, $file, $line, $sub ) = caller(1);
        $r->log_error(
            "Unknown log_level '$log_level' passed to logger() from $sub at line $line in $file "
        );
        $log_method = 'log_error';
    }
    $r->log->$log_method(@log_args);
}

1;

__END__

=head1 SUBCLASSING

You can subclass this module to override public functions and change
their behaviour.

=head1 CLASS METHODS

=head2 authen_cred($r, $user, $password, @extra_data)

Take the credentials for a user and check that they match; if so, return
a new session key for this user that can be stored in the cookie.
If there is a problem, return a bogus session key.

=head2 authen_ses_key($r, $encrypted_session_key)

Take a session key and check that it is still valid; if so, return the user.

=head2 decrypt_session_key($r, $encryptiontype, $encrypted_session_key, $secret_key)

Returns the decrypted session key or false on failure.

=head2 extra_session_info($r, $user, $password, @extra_data)

A stub method that you may want to override in a subclass.

This method returns extra fields to add to the session key.
It should return a string consisting of ":field1:field2:field3"
(where each field is preceded by a colon).

The default implementation returns an empty string.

=head2 group($r, $groups_string)

Take a string containing a whitespace-delimited list of groups and make sur
that the current remote user is a member of one of them.

Returns either I<Apache2::Const::HTTP_FORBIDDEN>
or I<Apache2::Const::OK>.

=head2 logger($r, $log_level, $message, $user, $log_type, @extra_args)

Calls one of the I<Apache::Log> methods with:

  ( $message, @extra_args )

for example, if the I<log_level> is I<Apache2::Const::LOG_DEBUG> then
this method will call: