view release on metacpan or  search on metacpan

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

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

    eval {
        $self->save_hash($hash);
    };
    if ($@) {
        warn "save_hash() failed, treating this request as invalid login.\n";
        warn "reason: $@";
        return;
    }

    return join '--', $hash, $data;
}

sub serialize_ticket {
    my ($self, $hashref) = @_;

    return MIME::Base64::encode( Storable::nfreeze($hashref), '' );
}

sub unserialize_ticket {
    my ($self, $data) = @_;

    return Storable::thaw( MIME::Base64::decode($data) );
}

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

    my $now     = time;
    my $expires = $now + $self->get_config('TicketExpires') * 60;

    return {
        version => $self->secret_version,
        time    => $now,
        user    => $user_name,
        expires => $expires
    };
}

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

    my $key = $self->key($r);
    warn "delete_ticket: key $key" if DEBUGGING;

    my ($hash) = split '--', $key or return;

    $self->delete_hash($hash);
}

########## SERVER SIDE HASH MANAGEMENT METHODS

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

    my $time = $self->request->request_time;
    my $dbh = $self->dbh;

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

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

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

# boolean _ticket_idle_timeout(String hash, Hashref ticket)
#
# return true if the ticket table timestamp is older than the IdleTimeout
# value.
sub _ticket_idle_timeout {
    my ($self, $hash, $ticket) = @_;

    my $idle = $self->get_config('TicketIdleTimeout') * 60;
    return 0 unless $idle;       # if not timeout set, its still valid.

    my $db_time = $self->{DBTicketTimeStamp};
    my $time = $self->request->request_time;
    if (DEBUGGING) {
        warn "Last activity: ", ($time - $db_time), " secs ago\n";
        warn "Fail if thats > ", ($idle), "\n";
    }

    if ( ($time - $db_time)  > $idle ) {
        # its timed out
        return 1;
    }
    else {
        return 0;
    }
}

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

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

    my ($query, @bind) = $self->sql->insert($table, {
        $tick_field => $hash,
        $ts_field   => $self->request->request_time });

    my $dbh = $self->dbh;

    eval {
        my $sth = $dbh->do($query, undef, @bind);
        $dbh->commit unless $dbh->{AutoCommit};
    };
    if ($@) {
        $dbh->rollback;
        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.