File Coverage

blib/lib/Dancer2/Core/Role/SessionFactory.pm
Criterion Covered Total %
statement 96 103 93.2
branch 20 30 66.6
condition 4 9 44.4
subroutine 20 22 90.9
pod 10 12 83.3
total 150 176 85.2


line stmt bran cond sub pod time code
1             package Dancer2::Core::Role::SessionFactory;
2             # ABSTRACT: Role for session factories
3             $Dancer2::Core::Role::SessionFactory::VERSION = '1.0.0';
4 116     116   95605 use Moo::Role;
  116         401  
  116         1161  
5             with 'Dancer2::Core::Role::Engine';
6              
7 116     116   61073 use Carp 'croak';
  116         462  
  116         5893  
8 116     116   54531 use Dancer2::Core::Session;
  116         480  
  116         3835  
9 116     116   1053 use Dancer2::Core::Types;
  116         370  
  116         696  
10 116     116   1587496 use Digest::SHA 'sha1';
  116         387425  
  116         10808  
11 116     116   1177 use List::Util 'shuffle';
  116         338  
  116         8801  
12 116     116   54290 use MIME::Base64 'encode_base64url';
  116         78120  
  116         7916  
13 116     116   2056 use Module::Runtime 'require_module';
  116         3929  
  116         1339  
14 116     116   8118 use Ref::Util qw< is_ref is_arrayref is_hashref >;
  116         1472  
  116         201362  
15              
16 20335     20335 0 46698 sub hook_aliases { +{} }
17             sub supported_hooks {
18 34     34 0 639 qw/
19             engine.session.before_retrieve
20             engine.session.after_retrieve
21              
22             engine.session.before_create
23             engine.session.after_create
24              
25             engine.session.before_change_id
26             engine.session.after_change_id
27              
28             engine.session.before_destroy
29             engine.session.after_destroy
30              
31             engine.session.before_flush
32             engine.session.after_flush
33             /;
34             }
35              
36             sub _build_type {
37 0     0   0 'SessionFactory';
38             } # XXX vs 'Session'? Unused, so I can't tell -- xdg
39              
40             has log_cb => (
41             is => 'ro',
42             isa => CodeRef,
43             default => sub { sub {1} },
44             );
45              
46             has cookie_name => (
47             is => 'ro',
48             isa => Str,
49             default => sub {'dancer.session'},
50             );
51              
52             has cookie_domain => (
53             is => 'ro',
54             isa => Str,
55             predicate => 1,
56             );
57              
58             has cookie_path => (
59             is => 'ro',
60             isa => Str,
61             default => sub {"/"},
62             );
63              
64             has cookie_duration => (
65             is => 'ro',
66             isa => Str,
67             predicate => 1,
68             );
69              
70             has session_duration => (
71             is => 'ro',
72             isa => Num,
73             predicate => 1,
74             );
75              
76             has is_secure => (
77             is => 'rw',
78             isa => Bool,
79             default => sub {0},
80             );
81              
82             has is_http_only => (
83             is => 'rw',
84             isa => Bool,
85             default => sub {1},
86             );
87              
88             has cookie_same_site => (
89             is => 'ro',
90             isa => Str,
91             predicate => 1,
92             coerce => sub { ucfirst $_[0] },
93             );
94              
95             sub create {
96 10046     10046 1 274075 my ($self) = @_;
97              
98 10046         20196 my %args = ( id => $self->generate_id, );
99              
100 10046 100       112896 $args{expires} = $self->cookie_duration
101             if $self->has_cookie_duration;
102              
103 10046         182126 my $session = Dancer2::Core::Session->new(%args);
104              
105 10046         207199 $self->execute_hook( 'engine.session.before_create', $session );
106              
107             # XXX why do we _flush now? Seems unnecessary -- xdg, 2013-03-03
108 10046         79050 eval { $self->_flush( $session->id, $session->data ) };
  10046         153144  
109 10046 50       21608 croak "Unable to create a new session: $@"
110             if $@;
111              
112 10046         26183 $self->execute_hook( 'engine.session.after_create', $session );
113 10046         85306 return $session;
114             }
115              
116             {
117             my $COUNTER = 0;
118             my $CPRNG_AVAIL = eval { require_module('Math::Random::ISAAC::XS'); 1; } &&
119             eval { require_module('Crypt::URandom'); 1; };
120              
121             # don't initialize until generate_id is called so the ISAAC algorithm
122             # is seeded after any pre-forking
123             my $CPRNG;
124              
125             # prepend epoch seconds so session ID is roughly monotonic
126             sub generate_id {
127 10047     10047 1 15203 my ($self) = @_;
128              
129 10047 50       18344 if ($CPRNG_AVAIL) {
130             $CPRNG ||= Math::Random::ISAAC::XS->new(
131 10047   66     20348 map { unpack( "N", Crypt::URandom::urandom(4) ) } 1 .. 256 );
  3840         104641  
132              
133             # include $$ to ensure $CPRNG wasn't forked by accident
134 10047         67327 return encode_base64url(
135             pack(
136             "N6",
137             time, $$, $CPRNG->irand,
138             $CPRNG->irand, $CPRNG->irand, $CPRNG->irand
139             )
140             );
141             }
142             else {
143 0         0 my $seed = (
144             rand(1_000_000_000) # a random number
145             . __FILE__ # the absolute path as a secret key
146             . $COUNTER++ # impossible to have two consecutive dups
147             . $$ # the process ID as another private constant
148             . "$self" # the instance's memory address for more entropy
149             . join( '', shuffle( 'a' .. 'z', 'A' .. 'Z', 0 .. 9 ) )
150              
151             # a shuffled list of 62 chars, another random component
152             );
153 0         0 return encode_base64url( pack( "Na*", time, sha1($seed) ) );
154             }
155              
156             }
157             }
158              
159             sub validate_id {
160 53     53 1 147 my ($self, $id) = @_;
161 53         484 return $id =~ m/^[A-Za-z0-9_\-~]+$/;
162             }
163              
164             requires '_retrieve';
165              
166             sub retrieve {
167 54     54 1 918 my ( $self, %params ) = @_;
168 54         125 my $id = $params{id};
169              
170 54         211 $self->execute_hook( 'engine.session.before_retrieve', $id );
171              
172 54         448 my $data;
173             # validate format of session id before attempt to retrieve
174 54         115 my $rc = eval {
175 54 100       271 $self->validate_id($id) && ( $data = $self->_retrieve($id) );
176             };
177 54 100       721 croak "Unable to retrieve session with id '$id'"
178             if ! $rc;
179              
180 51         168 my %args = ( id => $id, );
181              
182 51 50 33     307 $args{data} = $data
183             if $data and is_hashref($data);
184              
185 51 100       210 $args{expires} = $self->cookie_duration
186             if $self->has_cookie_duration;
187              
188 51         1267 my $session = Dancer2::Core::Session->new(%args);
189              
190 51         1315 $self->execute_hook( 'engine.session.after_retrieve', $session );
191 51         593 return $session;
192             }
193              
194             # XXX eventually we could perhaps require '_change_id'?
195              
196             sub change_id {
197 3     3 1 20 my ( $self, %params ) = @_;
198 3         9 my $session = $params{session};
199 3         51 my $old_id = $session->id;
200              
201 3         35 $self->execute_hook( 'engine.session.before_change_id', $old_id );
202              
203 3         36 my $new_id = $self->generate_id;
204 3         100 $session->id( $new_id );
205              
206 3         119 eval { $self->_change_id( $old_id, $new_id ) };
  3         18  
207 3 50       150 croak "Unable to change session id for session with id $old_id: $@"
208             if $@;
209              
210 3         15 $self->execute_hook( 'engine.session.after_change_id', $new_id );
211             }
212              
213             requires '_destroy';
214              
215             sub destroy {
216 17     17 1 204 my ( $self, %params ) = @_;
217 17         59 my $id = $params{id};
218 17         73 $self->execute_hook( 'engine.session.before_destroy', $id );
219              
220 17         97 eval { $self->_destroy($id) };
  17         91  
221 17 50       263 croak "Unable to destroy session with id '$id': $@"
222             if $@;
223              
224 17         77 $self->execute_hook( 'engine.session.after_destroy', $id );
225 17         206 return $id;
226             }
227              
228             requires '_flush';
229              
230             sub flush {
231 49     49 1 1160 my ( $self, %params ) = @_;
232 49         127 my $session = $params{session};
233 49         242 $self->execute_hook( 'engine.session.before_flush', $session );
234              
235 49         503 eval { $self->_flush( $session->id, $session->data ) };
  49         900  
236 49 50       390 croak "Unable to flush session: $@"
237             if $@;
238              
239 49         252 $self->execute_hook( 'engine.session.after_flush', $session );
240 49         1120 return $session->id;
241             }
242              
243             sub set_cookie_header {
244 88     88 1 347 my ( $self, %params ) = @_;
245             $params{response}->push_header(
246             'Set-Cookie',
247 88         315 $self->cookie( session => $params{session} )->to_header
248             );
249             }
250              
251             sub cookie {
252 88     88 1 223 my ( $self, %params ) = @_;
253 88         164 my $session = $params{session};
254 88 50 33     657 croak "cookie() requires a valid 'session' parameter"
255             unless is_ref($session) && $session->isa("Dancer2::Core::Session");
256              
257 88         1584 my %cookie = (
258             value => $session->id,
259             name => $self->cookie_name,
260             path => $self->cookie_path,
261             secure => $self->is_secure,
262             http_only => $self->is_http_only,
263             );
264              
265 88 100       4499 $cookie{same_site} = $self->cookie_same_site
266             if $self->has_cookie_same_site;
267              
268 88 50       312 $cookie{domain} = $self->cookie_domain
269             if $self->has_cookie_domain;
270              
271 88 100       1478 if ( my $expires = $session->expires ) {
272 14         139 $cookie{expires} = $expires;
273             }
274              
275 88         2164 return Dancer2::Core::Cookie->new(%cookie);
276             }
277              
278             requires '_sessions';
279              
280             sub sessions {
281 0     0 1   my ($self) = @_;
282 0           my $sessions = $self->_sessions;
283              
284 0 0         croak "_sessions() should return an array ref"
285             unless is_arrayref($sessions);
286              
287 0           return $sessions;
288             }
289              
290             1;
291              
292             __END__
293              
294             =pod
295              
296             =encoding UTF-8
297              
298             =head1 NAME
299              
300             Dancer2::Core::Role::SessionFactory - Role for session factories
301              
302             =head1 VERSION
303              
304             version 1.0.0
305              
306             =head1 DESCRIPTION
307              
308             Any class that consumes this role will be able to store, create, retrieve and
309             destroy session objects.
310              
311             The default values for attributes can be overridden in your Dancer2
312             configuration. See L<Dancer2::Config/Session-engine>.
313              
314             =head1 ATTRIBUTES
315              
316             =head2 cookie_name
317              
318             The name of the cookie to create for storing the session key
319              
320             Defaults to C<dancer.session>
321              
322             =head2 cookie_domain
323              
324             The domain of the cookie to create for storing the session key.
325             Defaults to the empty string and is unused as a result.
326              
327             =head2 cookie_path
328              
329             The path of the cookie to create for storing the session key.
330             Defaults to "/".
331              
332             =head2 cookie_duration
333              
334             Default duration before session cookie expiration. If set, the
335             L<Dancer2::Core::Session> C<expires> attribute will be set to the current time
336             plus this duration (expression parsed by L<Dancer2::Core::Time>).
337              
338             =head2 cookie_same_site
339              
340             Restricts the session cookie to a first-party or same-site context.
341             Defaults to the empty string and is unused as a result.
342             See L<Dancer2::Core::Cookie/same_site>.
343              
344             =head2 session_duration
345              
346             Duration in seconds before sessions should expire, regardless of cookie
347             expiration. If set, then SessionFactories should use this to enforce a limit
348             on session validity.
349              
350             =head2 is_secure
351              
352             Boolean flag to tell if the session cookie is secure or not.
353              
354             Default is false.
355              
356             =head2 is_http_only
357              
358             Boolean flag to tell if the session cookie is http only.
359              
360             Default is true.
361              
362             =head1 INTERFACE
363              
364             Following is the interface provided by this role. When specified the required
365             methods to implement are described.
366              
367             =head2 create
368              
369             Create a brand new session object and store it. Returns the newly created
370             session object.
371              
372             Triggers an exception if the session is unable to be created.
373              
374             my $session = MySessionFactory->create();
375              
376             This method does not need to be implemented in the class.
377              
378             =head2 generate_id
379              
380             Returns a randomly-generated, guaranteed-unique string.
381             By default, it is a 32-character, URL-safe, Base64 encoded combination
382             of a 32 bit timestamp and a 160 bit SHA1 digest of random seed data.
383             The timestamp ensures that session IDs are generally monotonic.
384              
385             The default algorithm is not guaranteed cryptographically secure, but it's
386             still reasonably strong for general use.
387              
388             If you have installed L<Math::Random::ISAAC::XS> and L<Crypt::URandom>,
389             the seed data will be generated from a cryptographically-strong
390             random number generator.
391              
392             This method is used internally by create() to set the session ID.
393              
394             This method does not need to be implemented in the class unless an
395             alternative method for session ID generation is desired.
396              
397             =head2 validate_id
398              
399             Returns true if a session id is of the correct format, or false otherwise.
400              
401             By default, this ensures that the session ID is a string of characters
402             from the Base64 schema for "URL Applications" plus the C<~> character.
403              
404             This method does not need to be implemented in the class unless an
405             alternative set of characters for session IDs is desired.
406              
407             =head2 retrieve
408              
409             Return the session object corresponding to the session ID given. If none is
410             found, triggers an exception.
411              
412             my $session = MySessionFactory->retrieve(id => $id);
413              
414             The method C<_retrieve> must be implemented. It must take C<$id> as a single
415             argument and must return a hash reference of session data.
416              
417             =head2 change_id
418              
419             Changes the session ID of the corresponding session.
420              
421             MySessionFactory->change_id(session => $session_object);
422              
423             The method C<_change_id> must be implemented. It must take C<$old_id> and
424             C<$new_id> as arguments and change the ID from the old one to the new one
425             in the underlying session storage.
426              
427             =head2 destroy
428              
429             Purges the session object that matches the ID given. Returns the ID of the
430             destroyed session if succeeded, triggers an exception otherwise.
431              
432             MySessionFactory->destroy(id => $id);
433              
434             The C<_destroy> method must be implemented. It must take C<$id> as a single
435             argument and destroy the underlying data.
436              
437             =head2 flush
438              
439             Make sure the session object is stored in the factory's backend. This method is
440             called to notify the backend about the change in the session object.
441              
442             The Dancer application will not call flush unless the session C<is_dirty>
443             attribute is true to avoid unnecessary writes to the database when no
444             data has been modified.
445              
446             An exception is triggered if the session is unable to be updated in the backend.
447              
448             MySessionFactory->flush(session => $session);
449              
450             The C<_flush> method must be implemented. It must take two arguments: the C<$id>
451             and a hash reference of session data.
452              
453             =head2 set_cookie_header
454              
455             Sets the session cookie into the response object
456              
457             MySessionFactory->set_cookie_header(
458             response => $response,
459             session => $session,
460             destroyed => undef,
461             );
462              
463             The C<response> parameter contains a L<Dancer2::Core::Response> object.
464             The C<session> parameter contains a L<Dancer2::Core::Session> object.
465              
466             The C<destroyed> parameter is optional. If true, it indicates the
467             session was marked destroyed by the request context. The default
468             C<set_cookie_header> method doesn't need that information, but it is
469             included in case a SessionFactory must handle destroyed sessions
470             differently (such as signalling to middleware).
471              
472             =head2 cookie
473              
474             Coerce a session object into a L<Dancer2::Core::Cookie> object.
475              
476             MySessionFactory->cookie(session => $session);
477              
478             =head2 sessions
479              
480             Return a list of all session IDs stored in the backend.
481             Useful to create cleaning scripts, in conjunction with session's creation time.
482              
483             The C<_sessions> method must be implemented. It must return an array reference
484             of session IDs (or an empty array reference).
485              
486             =head1 CONFIGURATION
487              
488             If there are configuration values specific to your session factory in your config.yml or
489             environment, those will be passed to the constructor of the session factory automatically.
490             In order to accept and store them, you need to define accessors for them.
491              
492             engines:
493             session:
494             Example:
495             database_connection: "some_data"
496              
497             In your session factory:
498              
499             package Dancer2::Session::Example;
500             use Moo;
501             with "Dancer2::Core::Role::SessionFactory";
502              
503             has database_connection => ( is => "ro" );
504              
505             You need to do this for every configuration key. The ones that do not have accessors
506             defined will just go to the void.
507              
508             =head1 AUTHOR
509              
510             Dancer Core Developers
511              
512             =head1 COPYRIGHT AND LICENSE
513              
514             This software is copyright (c) 2023 by Alexis Sukrieh.
515              
516             This is free software; you can redistribute it and/or modify it under
517             the same terms as the Perl 5 programming language system itself.
518              
519             =cut