Catalyst::Plugin::Session - Generic Session plugin - ties together server side storage and client side state required to maintain session data.

    # To get sessions to "just work", all you need to do is use these plugins:

    use Catalyst qw/
      Session
      Session::Store::FastMmap
      Session::State::Cookie
      /;

    # you can replace Store::FastMmap with Store::File - both have sensible
    # default configurations (see their docs for details)

    # more complicated backends are available for other scenarios (DBI storage,
    # etc)




    # after you've loaded the plugins you can save session data
    # For example, if you are writing a shopping cart, it could be implemented
    # like this:

    sub add_item : Local {
        my ( $self, $c ) = @_;

        my $item_id = $c->req->param("item");

        # $c->session is a hash ref, a bit like $c->stash
        # the difference is that it' preserved across requests

        push @{ $c->session->{items} }, $item_id;

        $c->forward("MyView");
    }

    sub display_items : Local {
        my ( $self, $c ) = @_;

        # values in $c->session are restored
        $c->stash->{items_to_display} =
          [ map { MyModel->retrieve($_) } @{ $c->session->{items} } ];

        $c->forward("MyView");
    }

    sub prepare_action {
        my $c = shift;

        # don't touch $c->session yet!

        $c->NEXT::prepare_action( @_ );

        $c->session;  # this is OK
        $c->sessionid; # this is also OK
    }

    $c->config('Plugin::Session' => {
        expires => 1234,
    });

    Copyright (c) 2005 the aforementioned authors. All rights
    reserved. This program is free software; you can redistribute
    it and/or modify it under the same terms as Perl itself.

#!/usr/bin/perl

package Catalyst::Plugin::Session;

use Moose;
with 'MooseX::Emulate::Class::Accessor::Fast';
use MRO::Compat;
use Catalyst::Exception ();
use Digest              ();
use overload            ();
use Object::Signature   ();
use Carp;

use namespace::clean -except => 'meta';

our $VERSION = '0.32';
$VERSION = eval $VERSION;

my @session_data_accessors; # used in delete_session

__PACKAGE__->mk_accessors(
        "_session_delete_reason",
        @session_data_accessors = qw/
          _sessionid
          _session
          _session_expires
          _extended_session_expires
          _session_data_sig
          _flash
          _flash_keep_keys
          _flash_key_hashes
          _tried_loading_session_id
          _tried_loading_session_data
          _tried_loading_session_expires
          _tried_loading_flash_data
          /
);

sub _session_plugin_config {
    my $c = shift;
    # FIXME - Start warning once all the state/store modules have also been updated.
    #$c->log->warn("Deprecated 'session' config key used, please use the key 'Plugin::Session' instead")
    #    if exists $c->config->{session}
    #$c->config->{'Plugin::Session'} ||= delete($c->config->{session}) || {};
    $c->config->{'Plugin::Session'} ||= $c->config->{session} || {};
}

sub setup {
    my $c = shift;

    $c->maybe::next::method(@_);

    $c->check_session_plugin_requirements;
    $c->setup_session;

    return $c;
}

sub check_session_plugin_requirements {
    my $c = shift;

    unless ( $c->isa("Catalyst::Plugin::Session::State")
        && $c->isa("Catalyst::Plugin::Session::Store") )
    {
        my $err =
          (     "The Session plugin requires both Session::State "
              . "and Session::Store plugins to be used as well." );

        $c->log->fatal($err);
        Catalyst::Exception->throw($err);
    }
}

sub setup_session {
    my $c = shift;

    my $cfg = $c->_session_plugin_config;

    %$cfg = (
        expires        => 7200,
        verify_address => 0,
        verify_user_agent => 0,
        %$cfg,
    );

    $c->maybe::next::method();
}

sub prepare_action {
    my $c = shift;

    $c->maybe::next::method(@_);

    if (    $c->_session_plugin_config->{flash_to_stash}
        and $c->sessionid
        and my $flash_data = $c->flash )
    {
        @{ $c->stash }{ keys %$flash_data } = values %$flash_data;
    }
}

sub finalize_headers {
    my $c = shift;

    # fix cookie before we send headers
    $c->_save_session_expires;

    return $c->maybe::next::method(@_);
}

sub finalize_body {
    my $c = shift;

    # We have to finalize our session *before* $c->engine->finalize_xxx is called,
    # because we do not want to send the HTTP response before the session is stored/committed to
    # the session database (or whatever Session::Store you use).
    $c->finalize_session;

    return $c->maybe::next::method(@_);
}

sub finalize_session {
    my $c = shift;

    $c->maybe::next::method(@_);

    $c->_save_session_id;
    $c->_save_session;
    $c->_save_flash;

    $c->_clear_session_instance_data;
}

sub _save_session_id {
    my $c = shift;

    # we already called set when allocating
    # no need to tell the state plugins anything new
}

sub _save_session_expires {
    my $c = shift;

    if ( defined($c->_session_expires) ) {
        my $expires = $c->session_expires; # force extension

        my $sid = $c->sessionid;
        $c->store_session_data( "expires:$sid" => $expires );
    }
}

sub _save_session {
    my $c = shift;

    if ( my $session_data = $c->_session ) {

        no warnings 'uninitialized';
        if ( Object::Signature::signature($session_data) ne
            $c->_session_data_sig )
        {
            $session_data->{__updated} = time();
            my $sid = $c->sessionid;
            $c->store_session_data( "session:$sid" => $session_data );
        }
    }
}

sub _save_flash {
    my $c = shift;

    if ( my $flash_data = $c->_flash ) {

        my $hashes = $c->_flash_key_hashes || {};
        my $keep = $c->_flash_keep_keys || {};
        foreach my $key ( keys %$hashes ) {
            if ( !exists $keep->{$key} and Object::Signature::signature( \$flash_data->{$key} ) eq $hashes->{$key} ) {
                delete $flash_data->{$key};
            }
        }

        my $sid = $c->sessionid;

        my $session_data = $c->_session;
        if (%$flash_data) {
            $session_data->{__flash} = $flash_data;
        }
        else {
            delete $session_data->{__flash};
        }
        $c->_session($session_data);
        $c->_save_session;
    }
}

sub _load_session_expires {
    my $c = shift;
    return $c->_session_expires if $c->_tried_loading_session_expires;
    $c->_tried_loading_session_expires(1);

    if ( my $sid = $c->sessionid ) {
        my $expires = $c->get_session_data("expires:$sid") || 0;

        if ( $expires >= time() ) {
            $c->_session_expires( $expires );
            return $expires;
        } else {
            $c->delete_session( "session expired" );
            return 0;
        }
    }

    return;
}

sub _load_session {
    my $c = shift;
    return $c->_session if $c->_tried_loading_session_data;
    $c->_tried_loading_session_data(1);

    if ( my $sid = $c->sessionid ) {
        if ( $c->_load_session_expires ) {    # > 0

            my $session_data = $c->get_session_data("session:$sid") || return;
            $c->_session($session_data);

            no warnings 'uninitialized';    # ne __address
            if (   $c->_session_plugin_config->{verify_address}
                && exists $session_data->{__address}
                && $session_data->{__address} ne $c->request->address )
            {
                $c->log->warn(
                        "Deleting session $sid due to address mismatch ("
                      . $session_data->{__address} . " != "
                      . $c->request->address . ")"
                );
                $c->delete_session("address mismatch");
                return;
            }
            if (   $c->_session_plugin_config->{verify_user_agent}
                && $session_data->{__user_agent} ne $c->request->user_agent )
            {
                $c->log->warn(
                        "Deleting session $sid due to user agent mismatch ("
                      . $session_data->{__user_agent} . " != "
                      . $c->request->user_agent . ")"
                );
                $c->delete_session("user agent mismatch");
                return;
            }

            $c->log->debug(qq/Restored session "$sid"/) if $c->debug;
            $c->_session_data_sig( Object::Signature::signature($session_data) ) if $session_data;
            $c->_expire_session_keys;

            return $session_data;
        }
    }

    return;
}

sub _load_flash {
    my $c = shift;
    return $c->_flash if $c->_tried_loading_flash_data;
    $c->_tried_loading_flash_data(1);

    if ( my $sid = $c->sessionid ) {

        my $session_data = $c->session;
        $c->_flash($session_data->{__flash});

        if ( my $flash_data = $c->_flash )
        {
            $c->_flash_key_hashes({ map { $_ => Object::Signature::signature( \$flash_data->{$_} ) } keys %$flash_data });

            return $flash_data;
        }
    }

    return;
}

sub _expire_session_keys {
    my ( $c, $data ) = @_;

    my $now = time;

    my $expire_times = ( $data || $c->_session || {} )->{__expire_keys} || {};
    foreach my $key ( grep { $expire_times->{$_} < $now } keys %$expire_times ) {
        delete $c->_session->{$key};
        delete $expire_times->{$key};
    }
}

sub _clear_session_instance_data {
    my $c = shift;
    $c->$_(undef) for @session_data_accessors;
    $c->maybe::next::method(@_); # allow other plugins to hook in on this
}

sub change_session_id {
    my $c = shift;

    my $sessiondata = $c->session;
    my $oldsid = $c->sessionid;
    my $newsid = $c->create_session_id;

    if ($oldsid) {
        $c->log->debug(qq/change_sessid: deleting session data from "$oldsid"/) if $c->debug;
        $c->delete_session_data("${_}:${oldsid}") for qw/session expires flash/;
    }

    $c->log->debug(qq/change_sessid: storing session data to "$newsid"/) if $c->debug;
    $c->store_session_data( "session:$newsid" => $sessiondata );

    return $newsid;
}

sub delete_session {
    my ( $c, $msg ) = @_;

    $c->log->debug("Deleting session" . ( defined($msg) ? "($msg)" : '(no reason given)') ) if $c->debug;

    # delete the session data
    if ( my $sid = $c->sessionid ) {
        $c->delete_session_data("${_}:${sid}") for qw/session expires flash/;
        $c->delete_session_id($sid);
    }

    # reset the values in the context object
    # see the BEGIN block
    $c->_clear_session_instance_data;

    $c->_session_delete_reason($msg);
}

sub session_delete_reason {
    my $c = shift;

    $c->session_is_valid; # check that it was loaded

    $c->_session_delete_reason(@_);
}

sub session_expires {
    my $c = shift;

    if ( defined( my $expires = $c->_extended_session_expires ) ) {
        return $expires;
    } elsif ( defined( $expires = $c->_load_session_expires ) ) {
        return $c->extend_session_expires( $expires );
    } else {
        return 0;
    }
}

sub extend_session_expires {
    my ( $c, $expires ) = @_;
    $c->_extended_session_expires( my $updated = $c->calculate_extended_session_expires( $expires ) );
    $c->extend_session_id( $c->sessionid, $updated );
    return $updated;
}

sub calculate_initial_session_expires {
    my $c = shift;
    return ( time() + $c->_session_plugin_config->{expires} );
}

sub calculate_extended_session_expires {
    my ( $c, $prev ) = @_;
    $c->calculate_initial_session_expires;
}

sub reset_session_expires {
    my ( $c, $sid ) = @_;

    my $exp = $c->calculate_initial_session_expires;
    $c->_session_expires( $exp );
    #
    # since we're setting _session_expires directly, make load_session_expires
    # actually use that value.
    #
    $c->_tried_loading_session_expires(1);
    $c->_extended_session_expires( $exp );
    $exp;
}

sub sessionid {
    my $c = shift;

    return $c->_sessionid || $c->_load_sessionid;
}

sub _load_sessionid {
    my $c = shift;
    return if $c->_tried_loading_session_id;
    $c->_tried_loading_session_id(1);

    if ( defined( my $sid = $c->get_session_id ) ) {
        if ( $c->validate_session_id($sid) ) {
            # temporarily set the inner key, so that validation will work
            $c->_sessionid($sid);
            return $sid;
        } else {
            my $err = "Tried to set invalid session ID '$sid'";
            $c->log->error($err);
            Catalyst::Exception->throw($err);
        }
    }

    return;
}

sub session_is_valid {
    my $c = shift;

    # force a check for expiry, but also __address, etc
    if ( $c->_load_session ) {
        return 1;
    } else {
        return;
    }
}

sub validate_session_id {
    my ( $c, $sid ) = @_;

    $sid and $sid =~ /^[a-f\d]+$/i;
}

sub session {
    my $c = shift;

    my $session = $c->_session || $c->_load_session || do {
        $c->create_session_id_if_needed;
        $c->initialize_session_data;
    };

    if (@_) {
      my $new_values = @_ > 1 ? { @_ } : $_[0];
      croak('session takes a hash or hashref') unless ref $new_values;

      for my $key (keys %$new_values) {
        $session->{$key} = $new_values->{$key};
      }
    }

    $session;
}

sub keep_flash {
    my ( $c, @keys ) = @_;
    my $href = $c->_flash_keep_keys || $c->_flash_keep_keys({});
    (@{$href}{@keys}) = ((undef) x @keys);
}

sub _flash_data {
    my $c = shift;
    $c->_flash || $c->_load_flash || do {
        $c->create_session_id_if_needed;
        $c->_flash( {} );
    };
}

sub _set_flash {
    my $c = shift;
    if (@_) {
        my $items = @_ > 1 ? {@_} : $_[0];
        croak('flash takes a hash or hashref') unless ref $items;
        @{ $c->_flash }{ keys %$items } = values %$items;
    }
}

sub flash {
    my $c = shift;
    $c->_flash_data;
    $c->_set_flash(@_);
    return $c->_flash;
}

sub clear_flash {
    my $c = shift;

    #$c->delete_session_data("flash:" . $c->sessionid); # should this be in here? or delayed till finalization?
    $c->_flash_key_hashes({});
    $c->_flash_keep_keys({});
    $c->_flash({});
}

sub session_expire_key {
    my ( $c, %keys ) = @_;

    my $now = time;
    @{ $c->session->{__expire_keys} }{ keys %keys } =
      map { $now + $_ } values %keys;
}

sub initialize_session_data {
    my $c = shift;

    my $now = time;

    return $c->_session(
        {
            __created => $now,
            __updated => $now,

            (
                $c->_session_plugin_config->{verify_address}
                ? ( __address => $c->request->address||'' )
                : ()
            ),
            (
                $c->_session_plugin_config->{verify_user_agent}
                ? ( __user_agent => $c->request->user_agent||'' )
                : ()
            ),
        }
    );
}

sub generate_session_id {
    my $c = shift;

    my $digest = $c->_find_digest();
    $digest->add( $c->session_hash_seed() );
    return $digest->hexdigest;
}

sub create_session_id_if_needed {
    my $c = shift;
    $c->create_session_id unless $c->sessionid;
}

sub create_session_id {
    my $c = shift;

    my $sid = $c->generate_session_id;

    $c->log->debug(qq/Created session "$sid"/) if $c->debug;

    $c->_sessionid($sid);
    $c->reset_session_expires;
    $c->set_session_id($sid);

    return $sid;
}

my $counter;

sub session_hash_seed {
    my $c = shift;

    return join( "", ++$counter, time, rand, $$, {}, overload::StrVal($c), );
}

my $usable;

sub _find_digest () {
    unless ($usable) {
        foreach my $alg (qw/SHA-1 SHA-256 MD5/) {
            if ( eval { Digest->new($alg) } ) {
                $usable = $alg;
                last;
            }
        }
        Catalyst::Exception->throw(
                "Could not find a suitable Digest module. Please install "
              . "Digest::SHA1, Digest::SHA, or Digest::MD5" )
          unless $usable;
    }

    return Digest->new($usable);
}

sub dump_these {
    my $c = shift;

    (
        $c->maybe::next::method(),

        $c->_sessionid
        ? ( [ "Session ID" => $c->sessionid ], [ Session => $c->session ], )
        : ()
    );
}


sub get_session_id { shift->maybe::next::method(@_) }
sub set_session_id { shift->maybe::next::method(@_) }
sub delete_session_id { shift->maybe::next::method(@_) }
sub extend_session_id { shift->maybe::next::method(@_) }

__PACKAGE__;

__END__