Catalyst::Authentication::Store::AuthTkt - shim for Apache::AuthTkt

    perldoc Catalyst::Authentication::AuthTkt

package Catalyst::Authentication::Store::AuthTkt;

use warnings;
use strict;
use base qw( Class::Accessor::Fast );
use Apache::AuthTkt 0.08;
use Carp;
use Data::Dump qw( dump );
use Catalyst::Authentication::User::AuthTkt;

__PACKAGE__->mk_accessors(qw( cookie_name aat config debug ));

our $VERSION = '0.11';

sub new {
    my ( $class, $config, $app ) = @_;
    my $self = $class->SUPER::new(
        { cookie_name => $config->{cookie_name} || 'auth_tkt' } );
    my @aat_args = ();
    for my $param (qw( cookie_name domain timeout timeout_refresh )) {
        if ( exists $config->{$param} ) {
            push( @aat_args, $param => $config->{$param} );
        }
    }
    if ( $config->{conf} ) {
        $self->{aat}
            = Apache::AuthTkt->new( conf => $config->{conf}, @aat_args );
    }
    elsif ( $config->{secret} ) {
        $self->{aat}
            = Apache::AuthTkt->new( secret => $config->{secret}, @aat_args );
    }
    else {
        croak "conf or secret configuration required";
    }
    unless ( defined $config->{timeout} ) {
        $config->{timeout}
            = defined $self->aat->timeout ? $self->aat->timeout : 7200;
    }
    unless ( defined $config->{timeout_refresh} ) {
        $config->{timeout_refresh}
            = defined $self->aat->timeout_refresh
            ? $self->aat->timeout_refresh
            : 0.5;
    }

    # make sure timeout is in seconds format
    if ( $config->{timeout} =~ m/\D/ ) {
        $config->{timeout}
            = $self->aat->convert_time_seconds( $config->{timeout} );
    }

    $self->config($config);    # cache for later
    $self->debug( $config->{debug} || $ENV{PERL_DEBUG} || 0 );

    return $self;
}

sub find_user {
    my ( $self, $userinfo, $c ) = @_;

    $c->log->debug('AuthTkt: authenticating request') if $self->debug;

    # mock feature for development when you just want to mimic cookie
    # (e.g., when running under localhost or different domain than
    # your auth server)
    if ( $self->config->{mock} ) {
        my %user = %{ $self->config->{mock} };

        $c->log->debug("AuthTkt: using mock user $user{id}") if $self->debug;

        return Catalyst::Authentication::User::AuthTkt->new(
            {   id     => $user{id},
                data   => '',
                ts     => '',
                tokens => $user{tokens},
                ticket => 'mock_auth_cookie',
            }
        );
    }

    # if no cookie or param, return undef
    my $cookie = $c->req->cookie( $self->cookie_name )
        || $c->req->params->{ $self->cookie_name };
    unless ($cookie) {
        $c->log->debug(
            "AuthTkt: No cookie or param for " . $self->cookie_name )
            if $self->debug;
        $c->logout;    # in case user was in session
        return;
    }

    # unpack cookie
    my $t = ref($cookie) ? $cookie->value : $cookie;
    if ( !defined $t or !length $t ) {
        $c->log->debug(
            "AuthTkt: no ticket value in cookie " . $self->cookie_name )
            if $self->debug;
        $c->logout;    # in case user was in session
        return;
    }
    $c->log->debug("AuthTkt: $t") if $self->debug;

# running under fcgi (others?) the REMOTE_ADDR env var is not set, which Apache::AuthTkt
# uses to check the validity of tickets if the ip_addr is not set explicitly in the AA object.
# So we set it explicitly here.
# if the 'ignore_ip' config option were used consistently (i.e. both setting and checking)
# then this hack would not be necessary, but we can't vouch for how the ticket was set.
    if (   !exists $ENV{REMOTE_ADDR}
        or $self->config->{use_req_address}
        or $ENV{REMOTE_ADDR} ne $c->req->address )
    {
        my $ipaddr = $self->config->{use_req_address} || $c->req->address;
        $c->log->debug("setting REMOTE_ADDR to $ipaddr")
            if $self->debug;
        $self->aat->{ip_addr} = $ipaddr;
    }

    my $ticket = $self->aat->validate_ticket($t);

    unless ( defined $ticket ) {
        $c->log->debug("AuthTkt: bad ticket detected") if $self->debug;
        $c->log->debug( "AuthTkt: parsed ticket looks like: "
                . dump( $self->aat->parse_ticket($t) ) )
            if $self->debug;
        $c->logout;    # in case user was in session
        return;
    }

    if ( $self->ticket_expired( $c, $ticket ) ) {
        $c->logout;    # in case user was in session
        return;
    }

    if ( $self->renew_ticket( $c, $ticket ) ) {
        $ticket = $self->aat->validate_ticket(
            $c->response->cookies->{ $self->cookie_name }->{value} );
    }

    $c->log->debug( 'AuthTkt: ' . dump($ticket) ) if $self->debug;

    # return user object
    return Catalyst::Authentication::User::AuthTkt->new(
        {   id     => $ticket->{uid},
            data   => $ticket->{data},
            ts     => $ticket->{ts},
            tokens => [ split( m/\s*,\s*/, $ticket->{tokens} || '' ) ],
            ticket => ref($cookie) ? $cookie->value : $cookie,
        }
    );

}

sub ticket_expired {
    my ( $self, $c, $ticket ) = @_;
    my $config    = $self->config;
    my $time_left = $ticket->{ts} + $config->{timeout} - time();

    if ( $time_left < 0 ) {

        if ( $self->debug ) {
            $c->log->debug( "AuthTkt: ticket has expired at "
                    . localtime( $ticket->{ts} + $config->{timeout} ) );
            $c->log->debug( "AuthTkt: timestamp in ticket was $ticket->{ts} ("
                    . localtime( $ticket->{ts} )
                    . ')' );
            $c->log->debug( 'AuthTkt: ticket was ' . dump($ticket) );
            $c->log->debug( "AuthTkt: cookie was "
                    . dump( $c->req->cookies->{ $config->{cookie_name} } ) );
            $c->log->debug(
                "AuthTkt: timeout in config was $config->{timeout}");
            $c->log->debug("AuthTkt: time left was $time_left");
        }
        return 1;
    }
    return 0;
}

sub renew_ticket {
    my ( $self, $c, $ticket ) = @_;
    my $config       = $self->config;
    my $time_left    = $ticket->{ts} + $config->{timeout} - time();
    my $more_seconds = $config->{timeout_refresh} * $config->{timeout};

    if (   $config->{timeout_refresh}
        && $time_left < $more_seconds )
    {
        $c->log->debug(
            "AuthTkt: ticket eligible for renewal: " . dump($ticket) )
            if $self->debug;

        # extend the expiration time of the cookie
        my $authtkt         = $self->aat;
        my $existing_cookie = $c->req->cookies->{ $self->cookie_name };
        my $new_ticket      = $authtkt->ticket(
            uid     => $ticket->{uid},
            ip_addr => $c->request->address,
            data    => $ticket->{data},
            tokens  => $ticket->{tokens},
        );
        $c->response->cookies->{ $self->cookie_name } = {
            value => $new_ticket,
            path  => defined $existing_cookie ? $existing_cookie->path
            : '/',
            domain => defined $existing_cookie->domain
            ? $existing_cookie->domain
            : $authtkt->domain
        };
        $c->log->debug( 'AuthTkt: new cookie: '
                . dump( $c->response->cookies->{ $self->cookie_name } ) )
            if $self->debug;
        if ( defined $c->user ) {
            $c->user->ticket($new_ticket);
        }
        return 1;
    }
    return 0;
}

sub expire_ticket {
    my ( $self, $c ) = @_;
    my $cookie_name     = $self->cookie_name;
    my $existing_cookie = $c->req->cookie($cookie_name);
    if ( !$existing_cookie ) {
        $c->log->warn("no cookie with name $cookie_name found to expire");
        return;
    }
    $existing_cookie->value( [] );
    $existing_cookie->expires( time - 100 );
    $existing_cookie->domain( $self->aat->domain )
        if $self->aat->domain;
    $c->res->cookies->{$cookie_name} = $existing_cookie;
    $c->log->debug( "AuthTkt: cookie reset as " . dump($existing_cookie) )
        if $self->debug;
}

sub for_session {
    my ( $self, $c, $user ) = @_;
    return $user;    # we serialize the whole user
}

sub from_session {
    my ( $self, $c, $frozen_user ) = @_;
    return $frozen_user;
}

1;    # End of Catalyst::Authentication::AuthTkt