File Coverage

blib/lib/YATT/Lite/WebMVC0/Partial/Session.pm
Criterion Covered Total %
statement 21 158 13.2
branch 0 90 0.0
condition 0 26 0.0
subroutine 7 31 22.5
pod 0 19 0.0
total 28 324 8.6


line stmt bran cond sub pod time code
1             package YATT::Lite::WebMVC0::Partial::Session;
2             sub MY () {__PACKAGE__}
3 12     12   83 use strict;
  12         35  
  12         410  
4 12     12   64 use warnings qw(FATAL all NONFATAL misc);
  12         30  
  12         511  
5 12     12   70 use Carp;
  12         29  
  12         958  
6              
7             use YATT::Lite::Partial
8 12         207 (requires => [qw/error
9             app_path_ensure_existing
10             app_path_var_tmp
11             /]
12             , fields => [qw/cf_session_driver
13             cf_session_config
14             cf_session_debug
15             cf_session_path
16             cf_csrftok_name
17             cf_tmpdir
18             /]
19             , -Entity, -CON
20 12     12   82 );
  12         29  
21              
22 12         901 use YATT::Lite::Util qw/lexpand escape nonempty symtab
23 12     12   88 num_is_ge/;
  12         43  
24              
25 12     12   82 use YATT::Lite::Types [Config => fields => [qw/name expire/]];
  12         27  
  12         122  
26              
27             #========================================
28              
29 12     12   84 use YATT::Lite::WebMVC0::Connection;
  12         29  
  12         19867  
30             sub Connection () {'YATT::Lite::WebMVC0::Connection'}
31             sub ConnProp () {Connection}
32              
33             #========================================
34             # Session support, based on CGI::Session.
35             #========================================
36              
37             Entity sess => sub {
38 0     0     my ($this) = shift;
39              
40             # This will call MY->session_resume.
41 0 0         my $sess = $CON->get_session
42             or return undef;
43              
44 0           $sess->param(@_);
45             };
46              
47             Entity csrf_token_input => sub {
48 0     0     my ($this, $name) = @_;
49 0   0       $name ||= $CON->cget('system')->csrftok_name;
50              
51 0           \ sprintf <get_session_sid);
52            
53             END
54             };
55              
56             Entity csrf_token_check => sub {
57 0     0     my ($this, $name) = @_;
58 0   0       $name ||= $CON->cget('system')->csrftok_name;
59              
60 0 0         nonempty(my $sid = $CON->get_session_sid)
61             or return undef;
62 0 0         nonempty(my $got = $CON->param($name))
63             or return undef;
64              
65 0           $sid eq $got;
66             };
67              
68             {
69             my $symtab = symtab(MY);
70             foreach my $meth (grep {/^session_/} keys %$symtab) {
71             my $sub = MY->can($meth);
72             Entity $meth => sub {
73 0     0     my $this = shift;
74 0           my ConnProp $prop = $CON->prop;
75 0           my MY $self = $prop->{cf_system};
76 0           $self->$meth($CON, @_);
77             };
78             }
79             }
80              
81             #========================================
82              
83             # This will be called back from $CON->get_session_sid.
84             sub session_sid {
85 0     0 0   (my MY $self, my ($con)) = @_;
86 0           my ConnProp $prop = $con->prop;
87 0           my $sid_name = $self->session_sid_name;
88 0 0         my $ck = $con->cookies_in->{$sid_name}
89             or return undef;
90 0           $ck->value;
91             }
92              
93             sub session_regenerate_id {
94 0     0 0   (my MY $self, my ($con, @with_init)) = @_;
95 0           my ConnProp $prop = $con->prop;
96              
97 0 0         if (defined $prop->{session}) {
98 0           $self->session_delete($con);
99             }
100              
101 0           $self->session_start($con, @with_init);
102             }
103              
104             # This will be called back from $CON->get_session.
105             # usually called from before_dirhandler
106             sub session_resume {
107 0     0 0   (my MY $self, my ($con)) = @_;
108             $con->logbacktrace("session.resume")
109 0 0         if num_is_ge($self->{cf_session_debug}, 2);
110              
111 0           my ConnProp $prop = $con->prop;
112              
113 0 0         if (exists $prop->{session}) {
114             $con->logdump("session.resume" => "session is already loaded")
115 0 0         if $self->{cf_session_debug};
116 0           return $prop->{session};
117             }
118 0           $prop->{session} = undef;
119              
120 0 0         my $sid = $self->session_sid($con) or do {
121             $con->logdump("session.resume" => "sid is empty")
122 0 0         if $self->{cf_session_debug};
123 0           return undef;
124             };
125              
126 0 0         my $sess = $self->session_create_by(load => $con, $sid)
127             or $self->error("Can't load session for sid='%s': %s"
128             , $sid, CGI::Session->errstr);
129              
130             CHK: {
131 0 0         if ($sess->is_expired) {
  0 0          
132             $con->logdump("session.resume" => expired => $sid)
133 0 0         if $self->{cf_session_debug};
134             } elsif (not $sess->id) {
135             $con->logdump("session.resume" => "id is empty"
136             , claimed_sid => $sid, sessobj => $sess)
137 0 0         if $self->{cf_session_debug};
138             } else {
139 0           last CHK;
140             }
141             # not ok.
142 0           delete $prop->{session}; # To allow calling session_start.
143 0           return undef; # XXX: Should we notify?
144             };
145              
146             $con->logdump("session.resume" => OK => sid => $sid)
147 0 0         if $self->{cf_session_debug};
148              
149 0           $prop->{session} = $sess;
150             }
151              
152             # This will be called back from $CON->start_session.
153             sub session_start {
154 0     0 0   (my MY $self, my ($con, @with_init)) = @_;
155              
156 0 0 0       my $opts = shift @with_init if @with_init and ref $with_init[0] eq 'HASH';
157 0   0       my $path = delete $opts->{path} || $self->session_path($con);
158 0 0         if (keys %$opts) {
159 0           $self->error("Invalid option for session_start: %s"
160             , join ", ", keys %$opts);
161             }
162              
163             $con->logbacktrace("session.start")
164 0 0         if num_is_ge($self->{cf_session_debug}, 2);
165              
166 0           my ConnProp $prop = $con->prop;
167              
168 0 0         if (defined $prop->{session}) {
169 0           $self->error("session is called twice! sid=%s", $prop->{session}->id);
170             }
171 0           $prop->{session} = undef;
172              
173 0 0         my $sess = $self->session_create_by(new => $con)
174             or $self->error("Can't create new session: %s", CGI::Session->errstr);
175              
176 0           $con->set_cookie($self->session_sid_name
177             , $sess->id
178             , -path => $path);
179 0           $sess->clear;
180 0 0         $self->session_init($con, $sess, @with_init) if @with_init;
181              
182 0           $prop->{session} = $sess;
183             }
184              
185             sub session_create_by {
186 0     0 0   (my MY $self, my ($method, $con, $sid)) = @_;
187 0           require CGI::Session;
188              
189 0           my ($type, %driver_opts) = $self->session_driver;
190 0           my Config $opts = $self->{cf_session_config};
191              
192 0   0       my $expire = delete($opts->{expire}) // $self->default_session_expire;
193 0 0         if (my $sess = CGI::Session->$method($type, $sid, \%driver_opts, $opts)) {
194 0 0         unless ($sess->is_expired) {
195 0           $sess->expire($expire);
196             }
197 0           return $sess;
198             }
199             }
200              
201             sub session_init {
202 0     0 0   my MY $self = shift;
203 0           my ConnProp $prop = (my $con = shift)->prop;
204 0           my ($sess, @with_init) = @_;
205              
206 0           foreach my $spec (@with_init) {
207 0 0         unless (defined $spec) {
    0          
    0          
208 0           $self->error("Undefined session initializer");
209 0           } elsif (ref $spec eq 'ARRAY') {
210 0           my ($name, @value) = @$spec;
211 0           $sess->param($name, @value);
212 0 0         } elsif (not ref $spec or ref $spec eq 'Regexp') {
213 0 0         $spec = qr{^\Q$spec} unless ref $spec;
214 0           foreach my $name ($con->param) {
215 0 0         next unless $name =~ $spec;
216 0           my (@value) = $con->param($name);
217 0           $sess->param($name, @value);
218             }
219             } else {
220 0           $self->error("Invalid session initializer: %s"
221             , terse_dump($spec));
222             }
223             }
224             }
225              
226             sub session_driver {
227 0     0 0   (my MY $self) = @_;
228             $self->{cf_session_driver}
229             ? lexpand($self->{cf_session_driver})
230 0 0         : $self->default_session_driver;
231             }
232              
233             sub session_delete {
234 0     0 0   my MY $self = shift;
235 0           my ConnProp $prop = (my $con = shift)->prop;
236 0           my $opts = shift;
237 0   0       my $path = delete $opts->{path} || $self->session_path($con);
238 0 0         if (keys %$opts) {
239 0           $self->error("Invalid option for session_delete: %s"
240             , join ", ", keys %$opts);
241             }
242              
243             $con->logbacktrace("session.delete")
244 0 0         if num_is_ge($self->{cf_session_debug}, 2);
245              
246 0 0         if (my $sess = delete $prop->{session}) {
247 0           my $sid = $sess->id;
248 0           $sess->delete;
249 0           $sess->flush;
250             $con->logdump("session.delete" => OK => sid => $sid)
251 0 0         if $self->{cf_session_debug};
252             } else {
253             $con->logdump("session.delete" => 'NOP')
254 0 0         if $self->{cf_session_debug};
255             }
256 0           my $name = $self->session_sid_name;
257 0           my @rm = ($name, '', -expires => '-10y', -path => $path);
258 0           $con->set_cookie(@rm);
259             }
260              
261             sub session_flush {
262 0     0 0   my MY $self = shift;
263 0           my ConnProp $prop = (my $glob = shift)->prop;
264             my $sess = $prop->{session}
265 0 0         or return;
266 0 0         return if $sess->errstr;
267 0           $sess->flush;
268 0 0         if (my $err = $sess->errstr) {
269 0           local $prop->{session};
270 0           $self->error("Can't flush session: %s", $err);
271             }
272             }
273              
274             sub configure_use_session {
275 0     0 0   (my MY $self, my $value) = @_;
276 0 0         if ($value) {
277             $self->{cf_session_config}
278 0 0 0       //= ref $value ? +{lexpand($value)} : +{$self->default_session_config};
279 0   0       $self->{cf_session_driver} //= [$self->default_session_driver];
280             }
281             }
282              
283             sub session_path {
284 0     0 0   (my MY $self, my ($con)) = @_;
285 0 0         $self->{cf_session_path} || $con->site_location;
286             }
287              
288             sub session_sid_name {
289 0     0 0   (my MY $self) = @_;
290 0           my Config $opts = $self->{cf_session_config};
291 0 0         $opts->{name} || $self->default_session_sid_name;
292             }
293              
294 0     0 0   sub default_session_expire { '1d' }
295 0     0 0   sub default_session_sid_name { 'SID' }
296       0 0   sub default_session_config {}
297              
298             sub default_session_driver {
299 0     0 0   (my MY $self) = @_;
300 0   0       my $tmpdir = $self->{cf_tmpdir} //= $self->app_path_var_tmp('sess');
301 0           ("driver:file"
302             , Directory => $tmpdir
303             )
304             }
305              
306             sub cmd_session_list {
307 0     0 0   (my MY $self, my @param) = @_;
308 0           print join("\t", qw(id created accessed), @param), "\n";
309 0           require CGI::Session;
310 0           my ($type, %driver_opts) = $self->session_driver;
311             CGI::Session->find($type, sub {
312 0     0     my ($sess) = @_;
313 0 0         print join("\t", map {defined $_ ? $_ : "(undef)"}
314             $sess->id, $sess->ctime, $sess->atime
315 0           , map {$sess->param($_)} @param), "\n";
  0            
316 0           }, \%driver_opts);
317             }
318              
319              
320             sub csrftok_name {
321 0     0 0   (my MY $self) = @_;
322 0 0         $self->{cf_csrftok_name} || $self->default_csrftok_name;
323             }
324              
325 0     0 0   sub default_csrftok_name { '--csrftok' }
326              
327             1;