view release on metacpan or  search on metacpan

AuthCookieDBI.pm  view on Meta::CPAN

=cut

    $c{DBI_sessionlifetime} = _dir_config_var( $r, 'DBI_SessionLifetime' )
      || '00-24-00-00';

    return %c;
}

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

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

sub _percent_encode {
    my ($str) = @_;
    $str =~ s/([^\w])/ uc sprintf '%%%02x', ord $1 /eg;
    return $str;
}

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

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

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

=head1 SUBCLASSING

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

=over 4

=item C<extra_session_info()>

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 false.

=back

=cut

sub extra_session_info {
    my ( $self, $r, @credentials ) = @_;

    return;
}

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

sub authen_cred {
    my ( $self, $r,        @credentials )       = @_;
    my ( $user, $password, @extra_credentials ) = @credentials;
    my $auth_name = $r->auth_name;
    ( $user, $password ) = _defined_or_empty( $user, $password );

    if ( !length $user ) {
        $r->log_reason(
"Apache::AuthCookieDBI: no username supplied for auth realm $auth_name",
            $r->uri
        );
        return;
    }

    if ( !length $password ) {
        $r->log_reason(
"Apache::AuthCookieDBI: no password supplied for auth realm $auth_name",
            $r->uri
        );
        return;
    }

    # get the configuration information.
    my %c = _dbi_config_vars $r;

    # get the crypted password from the users database for this user.
    my $dbh = DBI->connect( $c{DBI_DSN}, $c{DBI_user}, $c{DBI_password} );
    unless ( defined $dbh ) {
        $r->log_reason(
"Apache::AuthCookieDBI: couldn't connect to $c{ DBI_DSN } for auth realm $auth_name",
            $r->uri
        );
        return;
    }
    my $sth = $dbh->prepare( <<"EOS" );
SELECT $c{ DBI_passwordfield }
FROM $c{ DBI_userstable }
WHERE $c{ DBI_userfield } = ?
EOS
    $sth->execute($user);
    my ($crypted_password) = $sth->fetchrow_array;
    unless ( defined $crypted_password ) {
        $r->log_reason(
"Apache::AuthCookieDBI: couldn't select password from $c{ DBI_DSN }, $c{ DBI_userstable }, $c{ DBI_userfield } for user $user for auth realm $auth_name",
            $r->uri
        );
        return;
    }

    # now return unless the passwords match.
    if ( lc $c{DBI_crypttype} eq 'none' ) {
        unless ( $password eq $crypted_password ) {
            $r->log_reason(
"Apache::AuthCookieDBI: plaintext passwords didn't match for user $user for auth realm $auth_name",
                $r->uri
            );
            return;
        }
    }
    elsif ( lc $c{DBI_crypttype} eq 'crypt' ) {
        my $salt = substr $crypted_password, 0, 2;
        unless ( crypt( $password, $salt ) eq $crypted_password ) {
            $r->log_reason(
"Apache::AuthCookieDBI: crypted passwords didn't match for user $user for auth realm $auth_name",
                $r->uri
            );
            return;
        }
    }
    elsif ( lc $c{DBI_crypttype} eq 'md5' ) {
        unless ( md5_hex($password) eq $crypted_password ) {
            $r->log_reason(
"Apache::AuthCookieDBI: MD5 passwords didn't match for user $user for auth realm $auth_name",
                $r->uri
            );
            return;
        }
    }

    # Create the expire time for the ticket.
    my $expire_time;

    # expire time in a zillion years if it's forever.
    if ( lc $c{DBI_sessionlifetime} eq 'forever' ) {
        $expire_time = '9999-01-01-01-01-01';
    }
    else {
        my ( $deltaday, $deltahour, $deltaminute, $deltasecond ) =
          split /-/, $c{DBI_sessionlifetime};

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

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

    # OK, now we stick the username and the current time and the expire
    # time 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";
    $public_part .= $self->extra_session_info( $r, @credentials );

    # Now we calculate the hash of this and the secret key and then
    # calculate the hash of *that* and the secret key again.
    my $secret_key = $SECRET_KEYS{$auth_name};
    unless ( defined $secret_key ) {
        $r->log_reason(
"Apache::AuthCookieDBI: didn't have the secret key for auth realm $auth_name",
            $r->uri
        );
        return;
    }
    my $hash =
      md5_hex( join ':', $secret_key,
        md5_hex( join ':', $public_part, $secret_key ) );

    # 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;
    if ( $c{DBI_encryptiontype} eq 'none' ) {
        $encrypted_session_key = $session_key;
    }
    elsif ( lc $c{DBI_encryptiontype} eq 'des' ) {
        $CIPHERS{"des:$auth_name"} ||= Crypt::CBC->new( $secret_key, 'DES' );
        $encrypted_session_key =
          $CIPHERS{"des:$auth_name"}->encrypt_hex($session_key);
    }
    elsif ( lc $c{DBI_encryptiontype} eq 'idea' ) {
        $CIPHERS{"idea:$auth_name"} ||= Crypt::CBC->new( $secret_key, 'IDEA' );
        $encrypted_session_key =
          $CIPHERS{"idea:$auth_name"}->encrypt_hex($session_key);
    }
    elsif ( lc $c{DBI_encryptiontype} eq 'blowfish' ) {
        $CIPHERS{"blowfish:$auth_name"} ||=
          Crypt::CBC->new( $secret_key, 'Blowfish' );
        $encrypted_session_key =
          $CIPHERS{"blowfish:$auth_name"}->encrypt_hex($session_key);
    }

    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 ( $self, $r, $encrypted_session_key ) = @_;

    my $auth_name = $r->auth_name;

    # Get the configuration information.
    my %c = _dbi_config_vars $r;

    # Get the secret key.
    my $secret_key = $SECRET_KEYS{$auth_name};
    unless ( defined $secret_key ) {
        $r->log_reason(
"Apache::AuthCookieDBI: didn't have the secret key from for auth realm $auth_name",
            $r->uri