site/cgi-bin/modules/BSE/Session.pm

   1 package BSE::Session;
   2 use strict;
   3 use CGI::Cookie;
   4 use BSE::DB;
   5 use BSE::CfgInfo qw/custom_class/;
   6
   7 our $VERSION = "1.002";
   8
   9 sub _session_require {
  10   my ($cfg) = @_;
  11
  12   my $class = _session_class($cfg);
  13   $class =~ s!::!/!g;
  14
  15   return "$class.pm";
  16 }
  17
  18 sub _session_class {
  19   my ($cfg) = @_;
  20
  21   return $cfg->entry('basic', 'session_class', "Apache::Session::MySQL");
  22 }
  23
  24 sub _send_session_cookie {
  25   my ($self, $session, $cfg) = @_;
  26
  27   my $debug = $cfg->entry('debug', 'cookies');
  28
  29   my $cookie_name = $cfg->entry('basic', 'cookie_name', 'sessionid');
  30   my %extras;
  31   if ($cfg->entry("basic", "http_only_session", 1)) {
  32     $extras{httponly} = 1;
  33   }
  34   if ($cfg->entry("basic", "secure_session")) {
  35     $extras{secure} = 1;
  36   }
  37   my $cookie = $self->make_cookie($cfg, $cookie_name => $session->{_session_id}, \%extras);
  38   BSE::Session->send_cookie($cookie);
  39
  40   print STDERR "Sent cookie: $cookie\n" if $debug;
  41
  42   my $custom = custom_class($cfg);
  43   if ($custom->can('send_session_cookie')) {
  44     $custom->send_session_cookie($cookie_name, $session, $session->{_session_id}, $cfg);
  45   }
  46 }
  47
  48 sub tie_it {
  49   my ($self, $session, $cfg) = @_;
  50
  51   my $require = _session_require($cfg);
  52   require $require;
  53
  54   my $cookie_name = $cfg->entry('basic', 'cookie_name', 'sessionid');
  55   my $lifetime = $cfg->entry('basic', 'cookie_lifetime') || '+3h';
  56   my $debug = $cfg->entry('debug', 'cookies');
  57   my %cookies = fetch CGI::Cookie;
  58   if ($debug) {
  59     require Data::Dumper;
  60     print STDERR "Received cookies: ", Data::Dumper::Dumper(\%cookies);
  61   }
  62   my $sessionid;
  63   $sessionid = $cookies{$cookie_name}->value if exists $cookies{$cookie_name};
  64
  65   my $dh = BSE::DB->single;
  66   eval {
  67     tie %$session, _session_class($cfg), $sessionid,
  68     {
  69      Handle=>$dh->{dbh},
  70      LockHandle=>$dh->{dbh}
  71     };
  72   };
  73   print STDERR "Error getting session: $@\n" if $@ && $debug;
  74   if ($@ && $@ =~ /Object does not exist/) {
  75     # try again
  76     undef $sessionid;
  77     tie %$session, _session_class($cfg), $sessionid,
  78     {
  79      Handle=>$dh->{dbh},
  80      LockHandle=>$dh->{dbh}
  81     };
  82   }
  83   unless ($sessionid) {
  84     # save the new sessionid
  85     $self->_send_session_cookie($session, $cfg);
  86   }
  87
  88   if ($cfg->entry('debug', 'dump_session')) {
  89     require Data::Dumper;
  90     print STDERR Data::Dumper->Dump([ $session ], [ 'session' ]);
  91   }
  92 }
  93
  94 sub change_cookie {
  95   my ($self, $session, $cfg, $sessionid, $newsession) = @_;
  96
  97   #my $cookie_name = $cfg->entry('basic', 'cookie_name', 'sessionid');
  98   #BSE::Session->send_cookie($self->make_cookie($cfg, $cookie_name, $sessionid));
  99   my $dh = BSE::DB->single;
 100   eval {
 101     tie %$newsession, _session_class($cfg), $sessionid,
 102     {
 103      Handle=>$dh->{dbh},
 104      LockHandle=>$dh->{dbh}
 105     };
 106   };
 107
 108   $self->_send_session_cookie($newsession, $cfg);
 109 }
 110
 111 sub make_cookie {
 112   my ($self, $cfg, $name, $value, $extras) = @_;
 113
 114   $extras ||= {};
 115   $extras->{lifetime} ||= $cfg->entry('basic', 'cookie_lifetime') || '+3h';
 116   $name = $cfg->entry('cookie names', $name, $name);
 117   my %opts =
 118     (
 119      -name => $name,
 120      -value => $value,
 121      -path => '/',
 122      map {; "-$_" => $extras->{$_} } keys %$extras,
 123     );
 124   my $domain = $ENV{HTTP_HOST};
 125   $domain =~ s/:\d+$//;
 126   $domain = $cfg->entry('basic', 'cookie_domain', $domain);
 127   if ($domain !~ /^\d+\.\d+\.\d+\.\d+$/) {
 128     $opts{"-domain"} = $domain;
 129   }
 130
 131   return CGI::Cookie->new(%opts);
 132 }
 133
 134 sub send_cookie {
 135   my ($class, $cookie) = @_;
 136
 137   if (exists $ENV{GATEWAY_INTERFACE}
 138       && $ENV{GATEWAY_INTERFACE} =~ /^CGI-Perl\//) {
 139     my $r = Apache->request or die;
 140     $r->header_out('Set-Cookie' => "$cookie");
 141   }
 142   else {
 143     print "Set-Cookie: $cookie\n";
 144   }
 145 }
 146
 147 sub clear {
 148   my ($class, $session) = @_;
 149
 150   my $tie = tied(%$session);
 151   if ($tie) {
 152     $tie->delete();
 153   }
 154 }
 155
 156 1;
 157
 158 =head1 NAME
 159
 160 BSE::Session - wrapper around Apache::Session for BSE.
 161
 162 =head1 SYNOPSIS
 163
 164   use BSE::Session;
 165   use BSE::Cfg
 166   my %session;
 167   my $cfg = BSE::Cfg->new;
 168   BSE::Session->tie_it(\%session, $cfg);
 169
 170   BSE::Session->clear($session);
 171
 172 =head1 DESCRIPTION
 173
 174 Provides a thinnish wrapper around Apache::Session, providing the interface
 175 to BSE's database abstraction, configuration, retries and cookie setup.
 176
 177 =head1 KEYS
 178
 179 =over
 180
 181 =item *
 182
 183 cart - the customer's shopping cart, should only be set on the secure side
 184
 185 =item *
 186
 187 custom - custom values set by shopping cart processing, should only be
 188 set on the secure side
 189
 190 =item *
 191
 192 userid - id of the logged on normal user.
 193
 194 =item *
 195
 196 adminuserid - id of the logged on admin user.
 197
 198 =item *
 199
 200 affiliate_code - id of the affiliate set by affiliate.pl
 201
 202 =back
 203
 204 =head1 AUTHOR
 205
 206 Tony Cook <tony@develop-help.com>
 207
 208 =cut