password results from the CPAN

Apache-AuthTicket

                $CONFIG{$auth_name}{$name},
                $DEFAULTS{$name});
    }

    return $self->{config}{$name}
}

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

    my $self = $class->new($r);

    my $action = $self->get_config('TicketLoginHandler');

    my $destination = $r->prev->uri;
    my $args = $r->prev->args;
    if ($args) {
        $destination .= "?$args";
    }

    $class->make_login_screen($r, $action, $destination);

    return $class->apache_const('OK');
}

sub make_login_screen {
    my ($self, $r, $action, $destination) = @_;

    if (DEBUGGING) {
        # log what we think is wrong.
        my $reason = $r->prev->subprocess_env("AuthCookieReason");
        $r->log_error("REASON FOR AUTH NEEDED: $reason");
        $reason = $r->prev->subprocess_env("AuthTicketReason");
        $r->log_error("AUTHTICKET REASON: $reason");
    }

    $r->content_type('text/html');

    $r->send_http_header if ModPerl::VersionUtil->is_mp1;

    $r->print(
        q{<!DOCTYPE HTML PUBLIC  "-//W3C//DTD HTML 3.2//EN">},
        q{<HTML>},
        q{<HEAD>},
        q{<TITLE>Log in</TITLE>},
        q{</HEAD>},
        q{<BODY bgcolor="#ffffff">},
        q{<H1>Please Log In</H1>}
    );

    $r->print(
        qq{<form method="post" action="$action">},
        qq{<input type="hidden" name="destination" value="$destination">},
        q{<table>},
        q{<tr>},
        q{<td>Name</td>},
        q{<td><input type="text" name="credential_0"></td>},
        q{</tr>},
        q{<tr>},
        q{<td>Password</td>},
        q{<td><input type="password" name="credential_1"></td>},
        q{</tr>},
        q{</table>},
        q{<input type="submit" value="Log In">},
        q{<p>},
        q{</form>},
        q{<EM>Note: </EM>},
        q{Set your browser to accept cookies in order for login to succeed.},
        q{You will be asked to log in again after some period of time.},
        q{</body></html>}
    );

    return $self->apache_const('OK');
}

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

    my $self = $class->new($r);

    $self->delete_ticket($r);
    $self->next::method($r); # AuthCookie logout

    $r->headers_out->add(Location => $self->get_config('TicketLogoutURI'));

    return $class->apache_const('REDIRECT');
}

##################### END STATIC METHODS ###########################3
sub new {
    my ($class, $r) = @_;

    return $class->SUPER::new({request => $r});
}

sub dbh {
    my $self = shift;

    unless (defined $self->_dbh) {
        $self->_dbh($self->dbi_connect);
    }

    $self->_dbh;
}

sub dbi_connect {
    my $self = shift;

    my $r         = $self->request;
    my $auth_name = $r->auth_name;

    my ($db, $user, $pass) = map {
        $self->get_config($_)
    } qw/TicketDB TicketDBUser TicketDBPassword/;

    my $dbh = DBI->connect_cached($db, $user, $pass)
        or die "DBI Connect failure: ", DBI->errstr, "\n";

    return $dbh;
}

sub check_credentials {
    my ($self, $user, $password) = @_;

    my ($table, $user_field, $pass_field) = $self->user_table;

    my ($stmt, @bind) =
        $self->sql->select($table, $pass_field, {$user_field => $user});

    my ($db_pass) = eval {
        $self->dbh->selectrow_array($stmt, undef, @bind);
    };
    if ($@) {
        $self->dbh->rollback;
        return 0;
    }

    unless (defined $db_pass) {
        # user not in database
        return 0;
    }

    my $style = $self->get_config('TicketPasswordStyle');

    if ($self->compare_password($style, $password, $db_pass)) {
        return 1;
    }
    else {
        return 0;
    }
}

sub fetch_secret {
    my ($self, $version) = @_;

    my $dbh = $self->dbh;

    my ($secret_table, $secret_field, $secret_version_field) = $self->secret_table;

    # generate SQL
    my @fields = ($secret_field, $secret_version_field);
    my %where = ( $secret_version_field => $version ) if defined $version;
    my $order = " $secret_version_field DESC LIMIT 1 ";
    my ($stmt, @bind) = $self->sql->select($secret_table, \@fields, \%where, $order);

    return eval {
        $dbh->selectrow_array($stmt, undef, @bind);
    };
    if ($@) {
        $dbh->rollback;
        die $@;
    }
}

sub secret_version {
    my $self = shift;

    unless (defined $self->_secret_version) {
        $self->_secret_version( ($self->fetch_secret)[1] );
    }

    return $self->_secret_version;
}

sub make_ticket {
    my ($self, $user_name) = @_;

    my $ticket = $self->new_ticket_for($user_name);

    my ($secret) = $self->fetch_secret($$ticket{version});

    my $data = $self->serialize_ticket($ticket);

    my @fields = ($secret, $data);

    # only add ip if TicketCheckIP is on.
    if ($self->get_config('TicketCheckIP')) {
        push @fields, $self->_client_ip;
    }

    if ($self->get_config('TicketCheckBrowser')) {
        push @fields, $self->user_agent;
    }

    my $hash = $self->hash_for(@fields);

lib/Apache/AuthTicket/Base.pm view on Meta::CPAN

        die $@;
    }
}

sub delete_hash {
    my ($self, $hash) = @_;

    my ($table, $tick_field) = $self->ticket_table;

    my ($query, @bind) = $self->sql->delete($table, { $tick_field => $hash });

    my $dbh = $self->dbh;

    eval {
        my $sth = $dbh->do($query, undef, @bind);
        $dbh->commit unless $dbh->{AutoCommit} || 0;
    };
    if ($@) {
        $dbh->rollback;
        die $@;
    }
}

sub is_hash_valid {
    my ($self, $hash) = @_;

    my ($table, $tick_field, $ts_field) = $self->ticket_table;

    my ($query, @bind) = $self->sql->select($table, [$tick_field, $ts_field], 
        { $tick_field => $hash });

    my $dbh = $self->dbh;

    my ($db_hash, $ts) = (undef, undef);
    eval {
        ($db_hash, $ts) = $dbh->selectrow_array($query, undef, @bind);
        $self->{DBTicketTimeStamp} = $ts;   # cache for later use.
    };
    if ($@) {
        $dbh->rollback;
        die $@;
    }

    return (defined $db_hash and $db_hash eq $hash) ? 1 : 0;
}

sub hash_for {
    my $self = shift;

    return Digest::MD5::md5_hex(@_);
}

sub user_agent {
    my $self = shift;

    return $ENV{HTTP_USER_AGENT}
        || $self->request->headers_in->get('User-Agent')
        || '';
}

sub compare_password {
    my ($self, $style, $check, $expected) = @_;

    if ($style eq 'crypt') {
        return crypt($check, $expected) eq $expected;
    }
    elsif ($style eq 'cleartext') {
        return $check eq $expected;
    }
    elsif ($style eq 'md5') {
        return Digest::MD5::md5_hex($check) eq $expected;
    }
    else {
        die "unrecognized password style '$style'";
    }

    return 0;
}

sub str_config_value {
    my $self = shift;

    for my $value (@_) {
        next unless defined $value;

        my $test = lc $value;

        # convert booleans to 1/0
        if ($test =~ /^(?:1|on|yes|true)$/) {
            return 1;
        }
        elsif ($test =~ /^(?:0|off|no|false)$/) {
            return 0;
        }
        else {
            # return value unchanged.
            return $value;
        }
    }

    return;
}

sub ticket_table {
    my $self = shift;

    return split ':', $self->get_config('TicketTable');
}

sub user_table {
    my $self = shift;

    return split ':', $self->get_config('TicketUserTable');
}

sub secret_table {
    my $self = shift;

    return split ':', $self->get_config('TicketSecretTable');
}

sub push_handler { die "unimplemented" }

sub set_user { die "unimplemented" }

sub apache_const { die "unimplemented" }

1;

__END__

=pod

=head1 NAME

lib/Apache/AuthTicket/Base.pm view on Meta::CPAN

invalid_hash

Ticket hash is not found in the database

=item *

expired_ticket

Ticket has expired

=item *

missing_secret

Secret that signed this ticket was not found

=item *

idle_timeout

Ticket idle timeout exceeded

=item *

tampered_hash

Ticket has been tampered with.  The checksum does not match the checksum in the
ticket

=back

=head2 sql

Get the C<SQL::Abstract> object.

=head2 get_config

 my $value = $self->get_config($name)

Get a configuration value, or its default value if the setting is not
configured.

=head2 make_login_screen

 my $result = $self->make_login_screen($r, $action, $destination)

Print out the login screen html, and return an Apache status code.

=head2 dbh

Get the database handle

=head2 dbi_connect

 my $dbh = $self->dbi_connect

Returns a new connection to the database

=head2 check_credentials

 my $ok = $self->check_credentials($username, $password)

Return C<true> if the credentials are valid

=head2 fetch_secret

 my ($value, $version) = $self->fetch_secret;
 my ($value) = $self->fetch_secret($version)

Return the secret and version of the secret.  if the C<version> argument is
present, return that specific version of the secret instead of the most recent
one.

=head2 secret_version

Returns the version of the current (most-recent) secret

=head2 make_ticket

 my $string = $self->make_ticket($username)

Creates a ticket string for the given username

=head2 serialize_ticket

 my $data = $self->serialize_ticket($hashref)

Encode the hashref in a format suitable for sending in a HTTP cookie

=head2 unserialize_ticket

 my $hashref = $self->unserialize_ticket($data)

Decode cookie data into hashref.  This is the opposite of serialize_ticket()

=head2 new_ticket_for

 my $hashref = $self->new_ticket_for($username)

Creates new ticket hashref for the given username.  You could overload this to
append extra fields to the ticket.

=head2 delete_ticket

 $self->delete_ticket($r)

Invalidates the ticket by expiring the cookie and deletes the hash from the database

=head2 save_hash

 $self->save_hash($hash)

save the hash value/checksum in the database

=head2 delete_hash

 $self->delete_hash($hash)

Remove the given hash from the database.

=head2 is_hash_valid

 my $ok = $self->is_hash_valid($hash)

Return C<true> if the given hash is in the local database

=head2 hash_for

 my $hash = $self->hash_for(@values)

Compute a hash for the given values

=head2 user_agent

 my $agent = $self->user_agent

Get the request client's user agent string

=head2 compare_password

 my $ok = $self->compare_password($style, $entered, $actual)

Check a password and return C<true> if C<entered> matches C<actual>.  C<style> specifys what type of password is in C<actual>, and is one of the following:

=over 4

=item *

crypt

standard UNIX C<crypt()> value

=item *

cleartext

plain text password

=item *

md5

MD5 hash of password

=back

=head2 str_config_value

 my $val = $self->str_config_value($name)

Get a configuration value.  This converts things like yes,on,true to C<1>, and
no,off,false to C<0>.  Multiple C<name> values may be given and the first
defined value will be returned.  If no config value is defined matching any of
the given C<name>'s, then C<undef> is returned.

=head2 ticket_table

 my ($name, $hash_col, $timestamp_col) = $self->ticket_table

Unpacks the config value C<TicketTable> into its components.

=head2 user_table

 my ($name, $hash_col, $timestamp_col) = $self->ticket_table

Unpacks the config value C<TicketUserTable> into its components.

=head2 secret_table

 my ($name, $hash_col, $timestamp_col) = $self->ticket_table

Unpacks the config value C<TicketSecretTable> into its components.

=head2 push_handler

 $class->push_handler($name => sub { ... });

B<Subclass Must Implement This>.  Push the given subroutine as a mod_perl
handler

=head2 set_user

 $self->set_user($username)

B<Subclass Must Implement This>.  Set the username for this request.

=head2 apache_const

 my $const = $self->apache_const($name)

B<Subclass Must Implement This>.  Return the given apache constant.

=head1 SOURCE

The development version is on github at L<http://github.com/mschout/apache-authticket>
and may be cloned from L<git://github.com/mschout/apache-authticket.git>

=head1 BUGS

Please report any bugs or feature requests to bug-apache-authticket@rt.cpan.org or through the web interface at:
 http://rt.cpan.org/Public/Dist/Display.html?Name=Apache-AuthTicket

=head1 AUTHOR

( run in 1.660 second using v1.01-cache-2.11-cpan-39bf76dae61 )