MasonX::Request::WithApacheSession2 - Add a session to the Mason Request object

  PerlSetVar  MasonRequestClass         MasonX::Request::WithApacheSession2
  PerlSetVar  MasonSessionCookieDomain  .example.com
  PerlSetVar  MasonSessionClass         Apache::Session::MySQL
  PerlSetVar  MasonSessionDataSource    dbi:mysql:somedb

  my $ah =
      HTML::Mason::ApacheHandler2->new
          ( request_class => 'MasonX::Request::WithApacheSession2',
            session_cookie_domain => '.example.com',
            session_class         => 'Apache::Session2::MySQL',
            session_data_source   => 'dbi:mysql:somedb',
          );

  $m->session->{foo} = 1;
  if ( $m->session->{bar}{baz} > 1 ) { ... }

  PerlSetVar  MasonRequestClass  MasonX::Request::WithApacheSession2

  request_class => 'MasonX::Request::WithApacheSession2'

package MasonX::Request::WithApacheSession2;

use 5.005;
use strict;

use vars qw($VERSION @ISA);

$VERSION = '0.01';

use Apache::Session;
use Apache::RequestRec;
use Apache::RequestUtil;

use HTML::Mason 1.16;
use HTML::Mason::Exceptions ( abbr => [ qw( param_error error ) ] );
use HTML::Mason::Request;

use Data::Dumper;

use Exception::Class ( 'HTML::Mason::Exception::NonExistentSessionID' =>
		       { isa => 'HTML::Mason::Exception',
			 description => 'A non-existent session id was used',
			 fields => [ 'session_id' ] },
		     );

use Params::Validate qw(:all);
Params::Validate::validation_options( on_fail => sub { param_error( join '', @_ ) } );

# This may change later
@ISA = qw(HTML::Mason::Request);

my %params =
    ( session_always_write =>
      { type => BOOLEAN,
	default => 1,
	descr => 'Whether or not to force a write before the session goes out of scope' },

      session_allow_invalid_id =>
      { type => BOOLEAN,
	default => 1,
	descr => 'Whether or not to allow a failure to find an existing session id' },

      session_args_param =>
      { type => SCALAR,
	default => undef,
	descr => 'Name of the parameter to use for session tracking' },

      session_use_cookie =>
      { type => BOOLEAN,
	default => 0,
	descr => 'Whether or not to use a cookie to track the session' },

      session_cookie_name =>
      { type => SCALAR,
	default => 'MasonX-Request-WithApacheSession2-cookie',
	descr => 'Name of cookie used by this module' },

      session_cookie_expires =>
      { type => UNDEF | SCALAR,
	default => '+1d',
	descr => 'Expiration time for cookies' },

      session_cookie_domain =>
      { type => UNDEF | SCALAR,
	default => undef,
	descr => 'Domain parameter for cookies' },

      session_cookie_path =>
      { type => SCALAR,
	default => '/',
	descr => 'Path for cookies' },

      session_cookie_secure =>
      { type => BOOLEAN,
	default => 0,
	descr => 'Are cookies sent only for SSL connections?' },

      session_cookie_resend =>
      { type => BOOLEAN,
	default => 1,
	descr => 'Resend the cookie on each request?' },

      session_class =>
      { type => SCALAR,
	descr => 'An Apache::Session class to use for sessions' },

      session_data_source =>
      { type => SCALAR,
	optional => 1,
	descr => 'The data source when using MySQL or PostgreSQL' },

      session_user_name =>
      { type => UNDEF | SCALAR,
	default => undef,
	descr => 'The user name to be used when connecting to a database' },

      session_password =>
      { type => UNDEF | SCALAR,
	default => undef,
	descr => 'The password to be used when connecting to a database' },

      session_lock_data_source =>
      { type => SCALAR,
	optional => 1,
	descr => 'The data source when using MySQL or PostgreSQL' },

      session_lock_user_name =>
      { type => UNDEF | SCALAR,
        default => undef,
	descr => 'The user name to be used when connecting to a database' },

      session_lock_password =>
      { type => UNDEF | SCALAR,
	default => undef,
	descr => 'The password to be used when connecting to a database' },

      session_handle =>
      { type => OBJECT,
        optional => 1,
	descr => 'An existing database handle to use' },

      session_lock_handle =>
      { type => OBJECT,
        optional => 1,
	descr => 'An existing database handle to use' },

      session_commit =>
      { type => BOOLEAN,
        default => 1,
	descr => 'Whether or not to auto-commit changes to the database' },

      session_transaction =>
      { type => BOOLEAN,
	default => 0,
	descr => 'The Transaction flag for Apache::Session' },

      session_directory =>
      { type => SCALAR,
	default => undef,
	descr => 'A directory to use when storing sessions' },

      session_lock_directory =>
      { type => SCALAR,
	default => undef,
	descr => 'A directory to use for locking when storing sessions' },

      session_file_name =>
      { type => SCALAR,
	optional => 1,
	descr => 'A DB_File to use' },

      session_store =>
      { type => SCALAR,
	optional => 1,
	descr => 'A storage class to use with the Flex module' },

      session_lock =>
      { type => SCALAR,
	optional => 1,
	descr => 'A locking class to use with the Flex module' },

      session_generate =>
      { type => SCALAR,
	default => 'MD5',
	descr => 'A session generator class to use with the Flex module' },

      session_serialize =>
      { type => SCALAR,
	optional => 1,
	descr => 'A serialization class to use with the Flex module' },

      session_textsize =>
      { type => SCALAR,
	optional => 1,
	descr => 'A parameter for the Sybase storage module' },

      session_long_read_len =>
      { type => SCALAR,
	optional => 1,
	descr => 'A parameter for the Oracle storage module' },

      session_n_sems =>
      { type => SCALAR,
	optional => 1,
	descr => 'A parameter for the Semaphore locking module' },

      session_semaphore_key =>
      { type => SCALAR,
	optional => 1,
	descr => 'A parameter for the Semaphore locking module' },

      session_mod_usertrack_cookie_name =>
      { type => SCALAR,
	optional => 1,
	descr => 'The cookie name used by mod_usertrack' },

      session_save_path =>
      { type => SCALAR,
	optional => 1,
	descr => 'Path used by Apache::Session::PHP' },

    );

__PACKAGE__->valid_params(%params);

# What set of parameters are required for each session class.
# Multiple array refs represent multiple possible sets of parameters
my %ApacheSession2Params =
    ( Flex     => [ [ qw( store lock generate serialize ) ] ],
      MySQL    => [ [ qw( data_source user_name password
                          lock_data_source lock_user_name lock_password ) ],
		    [ qw( handle lock_handle ) ] ],
      Postgres => [ [ qw( data_source user_name password commit ) ],
		    [ qw( handle commit ) ] ],
      File     => [ [ qw( directory lock_directory ) ] ],
      DB_File  => [ [ qw( file_name lock_directory ) ] ],

      PHP      => [ [ qw( save_path ) ] ],
    );

$ApacheSession2Params{Oracle} =
      $ApacheSession2Params{Sybase} =
      $ApacheSession2Params{Postgres};

my %OptionalApacheSession2Params =
    ( Sybase => [ [ qw( textsize ) ] ],
      Oracle => [ [ qw( long_read_len ) ] ],
    );

my %ApacheSession2FlexParams =
    ( store =>
      { MySQL    => [ [ qw( data_source user_name password ) ],
		      [ qw( handle ) ] ],
	Postgres => $ApacheSession2Params{Postgres},
	File     => [ [ qw( directory ) ] ],
	DB_File  => [ [ qw( file_name ) ] ],
      },
      lock =>
      { MySQL     => [ [ qw( lock_data_source lock_user_name lock_password ) ],
		       [ qw( lock_handle ) ] ],
	File      => [ [ ] ],
	Null      => [ [ ] ],
	Semaphore => [ [ ] ],
      },
      generate =>
      { MD5          => [ [ ] ],
	ModUniqueId  => [ [ ] ],
	ModUsertrack => [ [ qw( mod_usertrack_cookie_name )  ] ],
      },
      serialize =>
      { Storable => [ [ ] ],
	Base64   => [ [ ] ],
	UUEncode => [ [ ] ],
      },
    );

$ApacheSession2FlexParams{store}{Oracle} =
      $ApacheSession2FlexParams{store}{Sybase} =
      $ApacheSession2FlexParams{store}{Postgres};

my %OptionalApacheSession2FlexParams =
    ( Sybase => { store => [ qw( textsize ) ] },
      Oracle => { store => [ qw( long_read_len ) ] },
    );

sub _studly_form
{
    my $string = shift;
    $string =~ s/(?:^|_)(\w)/\U$1/g;
    return $string;
}

my %StudlyForm =
    ( map { $_ => _studly_form($_) }
      map { ref $_ ? @$_ :$_ }
      map { @$_ }
      ( values %ApacheSession2Params ),
      ( values %OptionalApacheSession2Params ),
      ( map { values %{ $ApacheSession2FlexParams{$_} } }
	keys %ApacheSession2FlexParams ),
      ( map { values %{ $OptionalApacheSession2FlexParams{$_} } }
	keys %OptionalApacheSession2FlexParams ),
    );

# why Apache::Session does this I do not know
$StudlyForm{textsize} = 'textsize';

sub new
{

    my $class = shift;

    $class->alter_superclass( $HTML::Mason::ApacheHandler2::VERSION ?
                              'HTML::Mason::Request::ApacheHandler2' :
                              $HTML::Mason::CGIHandler::VERSION ?
                              'HTML::Mason::Request::CGI' :
                              'HTML::Mason::Request' );

    my $self = $class->SUPER::new(@_);

    $self->_check_session_params;
    $self->_set_session_params;

    return if $self->is_subrequest;

    eval "require Apache::Session::$self->{session_class_piece}";
    die $@ if $@;

    $self->_make_session;

    $self->_bake_cookie
        if $self->{session_use_cookie} && ! $self->{session_cookie_is_baked};

    return $self;
}

sub _check_session_params
{
    my $self = shift;

    $self->{session_class_piece} = $self->{session_class};
    $self->{session_class_piece} =~ s/^Apache::Session:://;

    my $sets = $ApacheSession2Params{ $self->{session_class_piece} }
	or param_error "Invalid session class: $self->{session_class}";

    my $complete = $self->_check_sets($sets);

    param_error "Not all of the required parameters for your chosen session class ($self->{session_class}) were provided."
	unless $complete;

    if ( $self->{session_class_piece} eq 'Flex' )
    {
	foreach my $key ( keys %ApacheSession2FlexParams )
	{
	    my $subclass = $self->{"session_$key"};
	    my $sets = $ApacheSession2FlexParams{$key}{$subclass}
		or param_error "Invalid class for $key: $self->{$key}";

	    my $complete = $self->_check_sets($sets);

	    param_error "Not all of the required parameters for your chosen $key class ($subclass) were provided."
		unless $complete;
	}
    }
}

sub _check_sets
{
    my $self = shift;
    my $sets = shift;

    foreach my $set (@$sets)
    {
	return 1
	    if ( grep { exists $self->{"session_$_"} } @$set ) == @$set;
    }

    return 0;
}

sub _set_session_params
{
    my $self = shift;

    my %params;

    $self->_sets_to_params
	( $ApacheSession2Params{ $self->{session_class_piece} },
	  \%params );

    $self->_sets_to_params
	( $OptionalApacheSession2Params{ $self->{session_class_piece} },
	  \%params );


    if ( $self->{session_class_piece} eq 'Flex' )
    {
	foreach my $key ( keys %ApacheSession2FlexParams )
	{
	    my $subclass = $self->{"session_$key"};
	    $params{ $StudlyForm{$key} } = $subclass;

	    $self->_sets_to_params
		( $ApacheSession2FlexParams{$key}{$subclass},
		  \%params );

	    $self->_sets_to_params
		( $OptionalApacheSession2FlexParams{$key}{$subclass},
		  \%params );
	}
    }

    $self->{session_params} = \%params;

    if ( $self->{session_use_cookie} )
    {
        if ( $self->can('apache_req') )
        {
            eval { require Apache::Cookie; Apache::Cookie->can('bake'); };
            unless ($@)
            {
                $self->{cookie_class} = 'Apache::Cookie';
                $self->{new_cookie_args} =
		    [ $self->apache_req->can( 'env' ) ?
		      $self->apache_req->env : $self->apache_req ];
            }
        }

        unless ( $self->{cookie_class} )
        {
            require CGI::Cookie;
            $self->{cookie_class} = 'CGI::Cookie';
            $self->{new_cookie_args} = [];
        }
    }
}

sub _sets_to_params
{
    my $self = shift;
    my $sets = shift;
    my $params = shift;

    foreach my $set (@$sets)
    {
	foreach my $key (@$set)
	{
	    if ( exists $self->{"session_$key"} )
	    {
		$params->{ $StudlyForm{$key} } =
		    $self->{"session_$key"};
	    }
	}
    }
}

sub _make_session
{
    my $self = shift;
    my %p = validate( @_,
		      { session_id =>
			{ type => SCALAR,
                          optional => 1,
			},
		      } );

    return if
        defined $p{session_id} && $self->_try_session_id( $p{session_id} );

    if ( defined $self->{session_args_param} )
    {
        my $id = $self->_get_session_id_from_args;

        return if defined $id && $self->_try_session_id($id);
    }

    if ( $self->{session_use_cookie} )
    {
        my $id = $self->_get_session_id_from_cookie;

        if ( defined $id && $self->_try_session_id($id) )
        {
            $self->{session_cookie_is_baked} = 1
                unless $self->{session_cookie_resend};

            return;
        }
    }

    # make a new session id
    $self->_try_session_id(undef);
}

sub _get_session_id_from_args
{
    my $self = shift;

    my $args = $self->request_args;

    return $args->{ $self->{session_args_param} }
        if exists $args->{ $self->{session_args_param} };

    return undef;
}

sub _try_session_id
{
    my $self = shift;
    my $session_id = shift;

    return 1 if ( $self->{session} &&
                  defined $session_id &&
                  $self->{session_id} eq $session_id );

    my %s;
    {
	local $SIG{__DIE__};
	eval
	{
	    tie %s, "Apache::Session::$self->{session_class_piece}",
                $session_id, $self->{session_params};
	};

        if ($@)
        {
            $self->_handle_tie_error( $@, $session_id );
            return;
        }
    }

    untie %{ $self->{session} } if $self->{session};

    $self->{session} = \%s;
    $self->{session_id} = $s{_session_id};

    $self->{session_cookie_is_baked} = 0;

    return 1;
}

sub _get_session_id_from_cookie
{
    my $self = shift;

    my %c = $self->{cookie_class} eq 'Apache::Cookie' ?
	$self->{cookie_class}->fetch
	( $self->apache_req->can( 'env' ) ?
	  $self->apache_req->env : $self->apache_req ) :
	$self->{cookie_class}->fetch ;

    return $c{ $self->{session_cookie_name} }->value
        if exists $c{ $self->{session_cookie_name} };

    return undef;
}

sub _handle_tie_error
{
    my $self = shift;
    my $err = shift;
    my $session_id = shift;

    if ( $err =~ /Object does not exist/ )
    {
        return if $self->{session_allow_invalid_id};

        HTML::Mason::Exception::NonExistentSessionID->throw
            ( error => "Invalid session id: $session_id",
                  session_id => $session_id );
    }
    else
    {
        die $@;
    }
}

sub _bake_cookie
{
    my $self = shift;

    my $expires = shift || $self->{session_cookie_expires};

    my $domain = $self->{session_cookie_domain};

    my $cookie =
        $self->{cookie_class}->new
            ( @{ $self->{new_cookie_args} },
              -name    => $self->{session_cookie_name},
              -value   => $self->{session_id},
              -expires => $expires,
              ( defined $self->{session_cookie_domain} ?
                ( -domain  => $domain ) :
                ()
              ),
              -path    => $self->{session_cookie_path},
              -secure  => $self->{session_cookie_secure},
            );

    if ( $cookie->can('bake') )
    {
        # Apache::Cookie
        $cookie->bake;
    }
    else
    {
        if ( $self->can('apache_req') )
        {
            # works when we're a subclass of
            # HTML::Mason::Request::ApacheHandler2
            $self->apache_req->err_headers_out->{'Set-Cookie'} = $cookie;
        }
        elsif ( $self->can('cgi_request') )
        {
            # works when we're a subclass of
            # HTML::Mason::Request::CGIHandler
            $self->cgi_request->headers_out->{ 'Set-Cookie' } = $cookie;
        }
        else
        {
            # no way to set headers!
            die "Cannot set cookie headers when using CGI::Cookie without any object to set them on.";
        }
    }

    # always set this even if we skipped actually setting the cookie
    # to avoid resending it.  this keeps us from entering this method
    # over and over
    $self->{session_cookie_is_baked} = 1
        unless $self->{session_cookie_resend};
}

sub exec
{
    my $self = shift;

    my @r;

    if (wantarray)
    {
	@r = $self->SUPER::exec(@_);
    }
    else
    {
	$r[0] = $self->SUPER::exec(@_);
    }

    unless ( $self->is_subrequest )
    {
	$self->_cleanup_session;
    }

    return wantarray ? @r : $r[0];
}

sub session
{
    my $self = shift;

    return $self->parent_request->session(@_) if $self->is_subrequest;

    if ( ! $self->{session} || @_ )
    {
        $self->_make_session(@_);

        $self->_bake_cookie
            if $self->{session_use_cookie} && ! $self->{session_cookie_is_baked};
    }

    return $self->{session};
}

sub delete_session
{
    my $self = shift;

    return unless $self->{session};

    my $session = delete $self->{session};

    (tied %$session)->delete;

    delete $self->{session_id};

    $self->_bake_cookie('-1d') if $self->{session_use_cookie};
}

sub _cleanup_session
{
    my $self = shift;

    if ( $self->{session_always_write} )
    {
	if ( $self->{session}->{___force_a_write___} )
	{
	    $self->{session}{___force_a_write___} = 0;
	}
	else
	{
	    $self->{session}{___force_a_write___} = 1;
	}
    }

    untie %{ $self->{session} };
}

1;

__END__