view release on metacpan or  search on metacpan

lib/Apache2_4/AuthCookieMultiDBI.pm  view on Meta::CPAN

        SetHandler perl-script
        PerlResponseHandler Apache2_4::AuthCookieMultiDBI->login

        # If the directopry you are protecting is the DocumentRoot directory
        # then uncomment the following directive:
        #Satisfy any
    </Files>

=head1 DESCRIPTION

This module is an authentication handler that uses the basic mechanism provided
by Apache2_4::AuthCookie with a DBI database for ticket-based protection. Actually
it is modified version of L<Apache2::AuthCookieDBI> for apache 2.4. It
is based on two tokens being provided, a username and password, which can
be any strings (there are no illegal characters for either).  The username is
used to set the remote user as if Basic Authentication was used.

On an attempt to access a protected location without a valid cookie being
provided, the module prints an HTML login form (produced by a CGI or any
other handler; this can be a static file if you want to always send people
to the same entry page when they log in).  This login form has fields for
username and password.  On submitting it, the username and password are looked
up in the DBI database.  The supplied password is checked against the password
in the database; the password in the database can be plaintext, or a crypt()
or md5_hex() checksum of the password.  If this succeeds, the user is issued
a ticket.  This ticket contains the username, an issue time, an expire time,
and an MD5 checksum of those and a secret key for the server.  It can
optionally be encrypted before returning it to the client in the cookie;
encryption is only useful for preventing the client from seeing the expire
time.  If you wish to protect passwords in transport, use an SSL-encrypted
connection.  The ticket is given in a cookie that the browser stores.

After a login the user is redirected to the location they originally wished
to view (or to a fixed page if the login "script" was really a static file).

On this access and any subsequent attempt to access a protected document, the
browser returns the ticket to the server.  The server unencrypts it if
encrypted tickets are enabled, then extracts the username, issue time, expire
time and checksum.  A new checksum is calculated of the username, issue time,
expire time and the secret key again; if it agrees with the checksum that
the client supplied, we know that the data has not been tampered with.  We
next check that the expire time has not passed.  If not, the ticket is still
good, so we set the username.

Authorization checks then check that any "require valid-user" or "require
user jacob" settings are passed.  Finally, if a "require group foo" directive
was given, the module will look up the username in a groups database and
check that the user is a member of one of the groups listed.  If all these
checks pass, the document requested is displayed.

If a ticket has expired or is otherwise invalid it is cleared in the browser
and the login form is shown again.

=cut

#===============================================================================
# P R I V A T E   F U N C T I O N S
#===============================================================================

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

sub _log_not_set {
    my ( $self, $r, $variable ) = @_;

    my $auth_name = $r->auth_name;
    my $message   = "${self} -> $variable not set for auth realm $auth_name";
    $r->server->log_error( $message );

    return;
}

#-------------------------------------------------------------------------------
# _dir_config_var -- Get a particular authentication variable.
#
sub _dir_config_var {
    my ( $self, $r, $variable ) = @_;

    my $auth_name = $r->auth_name;
    my $client    = EMPTY_STRING;

 #    if ($variable eq 'DBI_SecretKey') {
    #   $client = $self->get_client_name($r);
    # }

    #return $client . $r->dir_config("$auth_name$variable");
    return $r->dir_config("$auth_name$variable");
}

#-------------------------------------------------------------------------------
# _dbi_config_vars -- Get all authentication variable.
#
sub _dbi_config_vars {
    my ( $self, $r ) = @_;

    my %c;    # config variables hash
    foreach my $variable ( keys %CONFIG_DEFAULT ) {
        my $value_from_config = $self->_dir_config_var( $r, $variable );
        $c{$variable}
            = defined $value_from_config
            ? $value_from_config
            : $CONFIG_DEFAULT{$variable};
        if ( !defined $c{$variable} ) {
            $self->_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;
}

#-------------------------------------------------------------------------------
# _get_cipher_for_type - Get the cipher from the cache, or create a new one if the
# cached cipher hasn't been created.
# 
sub _get_cipher_for_type {
    my ( $self, $dbi_encryption_type, $auth_name, $secret_key ) = @_;
    my $lc_encryption_type = lc $dbi_encryption_type;
    my $message;

    if ( exists $CIPHERS{"$lc_encryption_type:$auth_name"} ) {
        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;
}

#-------------------------------------------------------------------------------
# _defined_or_empty - Takes a list and returns a list of the same size.
# Any element in the inputs that is defined is returned unchanged. Elements that
# were undef are returned as empty strings.
# 
sub _defined_or_empty {
    my @args        = @_;
    my @all_defined = ();
    foreach my $arg (@args) {
        if ( defined $arg ) {
            push @all_defined, $arg;
        }
        else {
            push @all_defined, EMPTY_STRING;
        }
    }
    return @all_defined;
}

#-------------------------------------------------------------------------------
# _is_empty - check empty string
# 
sub _is_empty {
    my $string = shift;
    return TRUE if not defined $string;
    return TRUE if $string eq EMPTY_STRING;
    return;
}

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

    Carp::confess('Failed to pass Apache request object') if not $r;

    my ( $pkg, $file, $line, $sub ) = caller(1);
    my $info_message = "${self} -> _dbi_connect called in $sub at line $line";
    $r->server->log_error( $info_message );

    my %c = $self->_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 $error_message = "${self} => couldn't connect to $c{'DBI_DSN'} for auth realm $auth_name";
        $r->server->log_error( $error_message );
        return;
    }
    
    if($c{'DBI_LoadClientDB'}) {

        my $client = $self->get_client_name($r);
        $dbh = $self->_dbi_connect_to_client($r, $client);

    }

    if ( defined $dbh ) {
        my $info_message = "${self} => connect to $c{'DBI_DSN'} for auth realm $auth_name";
        $r->server->log_error( $info_message );
        return $dbh;
    }
    
}

#-------------------------------------------------------------------------------
# _dbi_connect_to_client -- Get a database handle for client database.
# 
sub _dbi_connect_to_client {
    my ($self, $r, $client) = @_;

    my $auth_name = $r->auth_name;