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