view release on metacpan or  search on metacpan

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

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

    # Compare it to the hash they gave us.
    if ( $new_hash ne $hashed_string ) {
        my $message
            = "${class}\thash '$hashed_string' in cookie did not match calculated hash '$new_hash' of contents for user $user for auth realm $auth_name";
        $class->logger( $r, Apache2::Const::LOG_ERR, $message, $user,
            LOG_TYPE_TIMEOUT, $r->uri );
        return;
    }

    # Check that their session hasn't timed out.
    if ( _now_year_month_day_hour_minute_second gt $expire_time ) {
        my $message
            = "${class}\texpire time $expire_time has passed for user $user for auth realm $auth_name";
        $class->logger( $r, Apache2::Const::LOG_INFO, $message, $user,
            LOG_TYPE_TIMEOUT, $r->uri );
        return;
    }

    # If we're being paranoid about timing-out long-lived sessions,
    # check that the issue time + the current (server-set) session lifetime
    # hasn't passed too (in case we issued long-lived session tickets
    # in the past that we want to get rid of). *** TODO ***
    # if ( lc $c{'DBI_AlwaysUseCurrentSessionLifetime'} eq 'on' ) {

    # They must be okay, so return the user.
    return $user;
}

sub decrypt_session_key {
    my ( $class, $r, $encryptiontype, $encrypted_session_key, $secret_key )
        = @_;

    if ( $encryptiontype eq 'none' ) {
        return $encrypted_session_key;
    }

    my $auth_name = $r->auth_name;

    my $session_key;

    # Check that this looks like an encrypted hex-encoded string.
    if ( $encrypted_session_key !~ HEX_STRING_REGEX ) {
        my $message
            = "${class}\tencrypted session key '$encrypted_session_key' doesn't look like it's properly hex-encoded for auth realm $auth_name";
        $class->logger( $r, Apache2::Const::LOG_ERR, $message, undef,
            LOG_TYPE_SYSTEM, $r->uri );
        return;
    }

    my $cipher = $class->_get_cipher_for_type( $encryptiontype, $auth_name,
        $secret_key );
    if ( !$cipher ) {
        my $message
            = "${class}\tunknown encryption type '$encryptiontype' for auth realm $auth_name";
        $class->logger( $r, Apache2::Const::LOG_ERR, $message, undef,
            LOG_TYPE_SYSTEM, $r->uri );
        return;
    }
    $session_key = $cipher->decrypt_hex($encrypted_session_key);
    return $session_key;
}

sub group {
    my ( $class, $r, $groups ) = @_;
    my @groups = split( WHITESPACE_REGEX, $groups );

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

    # See if we have a row in the groups table for this user/group.
    my $dbh = $class->_dbi_connect($r, \%c)
      || return Apache2::Const::SERVER_ERROR;
    my $sth = $class->_prepare_group_query($dbh, \%c)
      || return Apache2::Const::SERVER_ERROR;

    return $class->_check_group_membership($r, $sth, \@groups)
      ? Apache2::Const::OK
      : Apache2::Const::HTTP_FORBIDDEN;
}

sub user_is_active {
    my ( $class, $r, $user, $config_hash ) = @_;
    my %c = $config_hash ? %$config_hash : $class->_dbi_config_vars($r);
    my $active_field_name = $c{'DBI_UserActiveField'};

    if ( !$active_field_name ) {
        return TRUE;    # Default is that users are active
    }

    my $dbh = $class->_dbi_connect($r, \%c) || return;
    my $ActiveFieldName = $dbh->quote_identifier($active_field_name);
    my $DBI_UsersTable = $dbh->quote_identifier($c{'DBI_UsersTable'});
    my $DBI_UserField  = $dbh->quote_identifier($c{'DBI_UserField'});

    my $sql_query = <<"SQL";
      SELECT $ActiveFieldName
      FROM $DBI_UsersTable
      WHERE $DBI_UserField = ?
SQL

    my $sth = $dbh->prepare_cached($sql_query);