view release on metacpan or  search on metacpan

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

        return $CIPHERS{"$lc_encryption_type:$auth_name"};
    }

    my %cipher_for_type = (
        des => sub {
            return $CIPHERS{"des:$auth_name"}
                || Crypt::CBC->new( -key => $secret_key, -cipher => 'DES' );
        },
        idea => sub {
            return $CIPHERS{"idea:$auth_name"}
                || Crypt::CBC->new( -key => $secret_key, -cipher => 'IDEA' );
        },
        blowfish => sub {
            return $CIPHERS{"blowfish:$auth_name"}
                || Crypt::CBC->new(
                -key    => $secret_key,
                -cipher => 'Blowfish'
                );
        },
        blowfish_pp => sub {
            return $CIPHERS{"blowfish_pp:$auth_name"}
                || Crypt::CBC->new(
                -key    => $secret_key,
                -cipher => 'Blowfish_PP'
                );
        },
    );
    my $code_ref = $cipher_for_type{$lc_encryption_type}
        || Carp::confess("Unsupported encryption type: '$dbi_encryption_type'");
    my $cbc_object = $code_ref->();

    # Cache the object. Caught bug where we were not, thanks to unit tests.
    $CIPHERS{"$lc_encryption_type:$auth_name"} = $cbc_object;

    return $cbc_object;
}

sub _encrypt_session_key {
    my $class               = shift;
    my $session_key         = shift;
    my $secret_key          = shift;
    my $auth_name           = shift;
    my $dbi_encryption_type = lc shift;
    my $message;

    if ( !defined $dbi_encryption_type ) {
        Carp::confess('$dbi_encryption_type must be defined.');
    }

    if ( $dbi_encryption_type eq 'none' ) {
        return $session_key;
    }

    my $cipher = $class->_get_cipher_for_type( $dbi_encryption_type, $auth_name,
        $secret_key );
    my $encrypted_key = $cipher->encrypt_hex($session_key);
    return $encrypted_key;
}

#-------------------------------------------------------------------------------
# _log_not_set -- Log that a particular authentication variable was not set.

sub _log_not_set {
    my ( $class, $r, $variable ) = @_;
    my $auth_name = $r->auth_name;
    my $message   = "${class}\t$variable not set for auth realm $auth_name";
    $class->logger( $r, Apache2::Const::LOG_ERR, $message, undef,
        LOG_TYPE_SYSTEM, $r->uri );
    return;
}

#-------------------------------------------------------------------------------
# _dir_config_var -- Get a particular authentication variable.

sub _dir_config_var {
    my ( $class, $r, $variable ) = @_;
    my $auth_name = $r->auth_name;
    return $r->dir_config("$auth_name$variable");
}

#-------------------------------------------------------------------------------
# _dbi_config_vars -- Gets the config variables from the dir_config and logs
# errors if required fields were not set, returns undef if any of the fields
# had errors or a hash of the values if they were all OK.  Takes a request
# object.

my %CONFIG_DEFAULT = (
    DBI_DSN             => undef,
    DBI_SecretKey       => undef,
    DBI_User            => undef,
    DBI_Password        => undef,
    DBI_UsersTable      => 'users',
    DBI_UserField       => 'user',
    DBI_PasswordField   => 'password',
    DBI_UserActiveField => EMPTY_STRING,    # Default is don't use this feature
    DBI_CryptType       => 'none',
    DBI_GroupsTable     => 'groups',
    DBI_GroupField      => 'grp',
    DBI_GroupUserField  => 'user',
    DBI_EncryptionType  => 'none',
    DBI_SessionLifetime => '00-24-00-00',
    DBI_sessionmodule   => 'none',
);

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

    my %c;    # config variables hash
    foreach my $variable ( keys %CONFIG_DEFAULT ) {
        my $value_from_config = $class->_dir_config_var( $r, $variable );
        $c{$variable}
            = defined $value_from_config
            ? $value_from_config
            : $CONFIG_DEFAULT{$variable};
        if ( !defined $c{$variable} ) {
            $class->_log_not_set( $r, $variable );
        }
    }

    # If we used encryption we need to pull in Crypt::CBC.
    if ( $c{'DBI_EncryptionType'} ne 'none' ) {
        require Crypt::CBC;
    }

    # Compile module for password encryption, if needed.
    if ( $c{'DBI_CryptType'} =~ /^sha/ ) {
        require Digest::SHA;
    }

    return %c;
}

=head1 APACHE CONFIGURATION DIRECTIVES

All configuration directives for this module are passed in PerlSetVars.  These
PerlSetVars must begin with the AuthName that you are describing, so if your
AuthName is PrivateBankingSystem they will look like:

    PerlSetVar PrivateBankingSystemDBI_DSN "DBI:mysql:database=banking"

See also L<Apache2::Authcookie> for the directives required for any kind
of Apache2::AuthCookie-based authentication system.

In the following descriptions, replace "WhatEver" with your particular
AuthName.  The available configuration directives are as follows:

=over 4

=item C<WhatEverDBI_DSN>

Specifies the DSN for DBI for the database you wish to connect to retrieve
user information.  This is required and has no default value.

=item C<WhateverDBI_SecretKey>

Specifies the secret key for this auth scheme.  This should be a long
random string.  This should be secret; either make the httpd.conf file
only readable by root, or put the PerlSetVar in a file only readable by
root and include it.

This is required and has no default value.  (NOTE: In AuthCookieDBI versions
1.22 and earlier the secret key either could be set in the configuration file
itself or it could be placed in a separate file with the path configured with
C<PerlSetVar WhateverDBI_SecretKeyFile>.

As of version 2.0, you must use C<WhateverDBI_SecretKey> and not
C<PerlSetVar WhateverDBI_SecretKeyFile>.

If you want to put the secret key in a separate file then you can create a
separate file that uses C<PerlSetVar WhateverDBI_SecretKey> and include that
file in your main Apache configuration using Apaches' C<Include>
directive. You might wish to make the file not
world-readable. Also, make sure that the Perl environment variables are
not publically available, for example via the /perl-status handler.)
See also L</"COMPATIBILITY"> in this man page.

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

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