view release on metacpan or  search on metacpan

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

This is not required and defaults to '00-24-00-00' or 24 hours.

=item C<WhatEverDBI_SessionModule>

Which Apache2::Session module to use for persistent sessions.
For example, a value could be "Apache2::Session::MySQL".  The DSN will
be the same as used for authentication.  The session created will be
stored in $r->pnotes( WhatEver ).

If you use this, you should put:

    PerlModule Apache2::Session::MySQL

(or whatever the name of your session module is) in your httpd.conf file,
so it is loaded.

If you are using this directive, you can timeout a session on the server side
by deleting the user's session.  Authentication will then fail for them.

This is not required and defaults to none, meaning no session objects will
be created.

=back

=cut

#-------------------------------------------------------------------------------
# _now_year_month_day_hour_minute_second -- Return a string with the time in
# 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'});

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

#===============================================================================
# P U B L I C   F U N C T I O N S
#===============================================================================

sub extra_session_info {
    my ( $class, $r, $user, $password, @extra_data ) = @_;

    return EMPTY_STRING;
}

sub authen_cred {
    my ( $class, $r, $user, $password, @extra_data ) = @_;
    my $auth_name = $r->auth_name;
    ( $user, $password ) = _defined_or_empty( $user, $password );

    if ( !length $user ) {
        my $message
            = "${class}\tno username supplied for auth realm $auth_name";
        $class->logger( $r, Apache2::Const::LOG_NOTICE, $message, $user,
            LOG_TYPE_AUTH, $r->uri );
        return;
    }

    if ( !length $password ) {
        my $message
            = "${class}\tno password supplied for auth realm $auth_name";
        $class->logger( $r, Apache2::Const::LOG_NOTICE, $message, $user,
            LOG_TYPE_AUTH, $r->uri );
        return;
    }

    # get the configuration information.
    my %c = $class->_dbi_config_vars($r);

    # get the crypted password from the users database for this user.
    my $crypted_password = $class->_get_crypted_password( $r, $user, \%c );
    return unless ( defined $crypted_password );

    # now return unless the passwords match.
    my $crypt_type = lc $c{'DBI_CryptType'};
    if ( !$class->_check_password( $password, $crypted_password, $crypt_type ) )
    {
        my $message
            = "${class}\tcrypt_type: '$crypt_type' - passwords didn't match for user '$user' for auth realm $auth_name";
        $class->logger( $r, Apache2::Const::LOG_NOTICE, $message, $user,
            LOG_TYPE_AUTH, $r->uri );
        return;
    }

    # Successful login
    my $message = "${class}\tSuccessful login for $user";
    $class->logger( $r, Apache2::Const::LOG_DEBUG, $message, $user,
        LOG_TYPE_AUTH, $r->uri );

    # Create the expire time for the ticket.
    my $expire_time = _get_expire_time( $c{'DBI_SessionLifetime'} );

    # Now we need to %-encode non-alphanumberics in the username so we
    # can stick it in the cookie safely.
    my $enc_user = _percent_encode($user);

    # If we are using sessions, we create a new session for this login.
    my $session_id = EMPTY_STRING;
    if ( $c{'DBI_sessionmodule'} ne 'none' ) {
        my $session = $class->_get_new_session( $r, $user, $auth_name,
            $c{'DBI_sessionmodule'}, \@extra_data );
        $r->pnotes( $auth_name, $session );
        $session_id = $session->{_session_id};
    }

    # OK, now we stick the username and the current time and the expire
    # time and the session id (if any) together to make the public part
    # of the session key:
    my $current_time = _now_year_month_day_hour_minute_second;
    my $public_part  = "$enc_user:$current_time:$expire_time:$session_id";
    $public_part
        .= $class->extra_session_info( $r, $user, $password, @extra_data );

    # Now we calculate the hash of this and the secret key and then
    # calculate the hash of *that* and the secret key again.
    my $secretkey = $c{'DBI_SecretKey'};
    if ( !defined $secretkey ) {
        my $message
            = "${class}\tdidn't have the secret key for auth realm $auth_name";
        $class->logger( $r, Apache2::Const::LOG_ERR, $message, $user,
            LOG_TYPE_SYSTEM, $r->uri );
        return;
    }
    my $hash = md5_hex( join q{:}, $secretkey,
        md5_hex( join q{:}, $public_part, $secretkey ) );

    # Now we add this hash to the end of the public part.
    my $session_key = "$public_part:$hash";

    # Now we encrypt this and return it.
    my $encrypted_session_key
        = $class->_encrypt_session_key( $session_key, $secretkey, $auth_name,
        $c{'DBI_EncryptionType'} );
    return $encrypted_session_key;
}

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

sub authen_ses_key {
    my ( $class, $r, $encrypted_session_key ) = @_;

    my $auth_name = $r->auth_name;

    # Get the configuration information.
    my %c = $class->_dbi_config_vars($r);

    # Get the secret key.
    my $secret_key = $c{'DBI_SecretKey'};
    if ( !defined $secret_key ) {
        my $message
            = "${class}\tdidn't have the secret key from for auth realm $auth_name";
        $class->logger( $r, Apache2::Const::LOG_ERR, $message, undef,
            LOG_TYPE_SYSTEM, $r->uri );
        return;
    }

    my $session_key = $class->decrypt_session_key( $r, $c{'DBI_EncryptionType'},
        $encrypted_session_key, $secret_key )
        || return;

    # Break up the session key.
    my ( $enc_user, $issue_time, $expire_time, $session_id, @rest )
        = split COLON_REGEX, $session_key;
    my $hashed_string = pop @rest;

    # Let's check that we got passed sensible values in the cookie.
    ($enc_user) = _defined_or_empty($enc_user);
    if ( $enc_user !~ PERCENT_ENCODED_STRING_REGEX ) {
        my $message
            = "${class}\tbad percent-encoded user '$enc_user' recovered from session ticket for auth_realm '$auth_name'";
        $class->logger( $r, Apache2::Const::LOG_ERR, $message, undef,
            LOG_TYPE_SYSTEM, $r->uri );
        return;
    }

    # decode the user
    my $user = _percent_decode($enc_user);

    ($issue_time) = _defined_or_empty($issue_time);
    if ( $issue_time !~ DATE_TIME_STRING_REGEX ) {
        my $message
            = "${class}\tbad issue time '$issue_time' recovered from ticket for user $user for auth_realm $auth_name";
        $class->logger( $r, Apache2::Const::LOG_ERR, $message, $user,
            LOG_TYPE_SYSTEM, $r->uri );
        return;
    }

    ($expire_time) = _defined_or_empty($expire_time);
    if ( $expire_time !~ DATE_TIME_STRING_REGEX ) {
        my $message
            = "${class}\tbad expire time $expire_time recovered from ticket for user $user for auth_realm $auth_name";
        $class->logger( $r, Apache2::Const::LOG_ERR, $message, $user,
            LOG_TYPE_SYSTEM, $r->uri );
        return;
    }
    if ( $hashed_string !~ THIRTY_TWO_CHARACTER_HEX_STRING_REGEX ) {
        my $message
            = "${class}\tbad encrypted session_key $hashed_string recovered from ticket for user $user for auth_realm $auth_name";
        $class->logger( $r, Apache2::Const::LOG_ERR, $message, $user,
            LOG_TYPE_SYSTEM, $r->uri );
        return;
    }

    # If we're using a session module, check that their session exist.
    if ( $c{'DBI_sessionmodule'} ne 'none' ) {
        my %session;
        my $dbh = $class->_dbi_connect($r) || return;

        my $tie_result = eval {
            tie %session, $c{'DBI_sessionmodule'}, $session_id,
                +{
                Handle     => $dbh,
                LockHandle => $dbh,
                };
        };
        if ( ( !$tie_result ) || $EVAL_ERROR ) {
            my $message
                = "${class}\tfailed to tie session hash to '$c{'DBI_sessionmodule'}' using session id $session_id for user $user for auth_realm $auth_name, error was '$EVAL_ERROR'";
            $class->logger( $r, Apache2::Const::LOG_ERR, $message, $user,
                LOG_TYPE_SYSTEM, $r->uri );
            return;
        }

        # Update a timestamp at the top level to make sure we sync.
        $session{timestamp} = _now_year_month_day_hour_minute_second;
        $r->pnotes( $auth_name, \%session );
    }

    # Calculate the hash of the user, issue time, expire_time and
    # the secret key  and the session_id and then the hash of that
    # and the secret key again.
    my $new_hash = md5_hex(
        join q{:},
        $secret_key,
        md5_hex(
            join q{:},   $enc_user, $issue_time, $expire_time,
            $session_id, @rest,     $secret_key