File Coverage

blib/lib/Plack/Middleware/Session/Cookie.pm
Criterion Covered Total %
statement 35 65 53.8
branch 4 16 25.0
condition n/a
subroutine 10 21 47.6
pod 2 8 25.0
total 51 110 46.3


line stmt bran cond sub pod time code
1             package Plack::Middleware::Session::Cookie;
2 1     1   59324 use strict;
  1         8  
  1         26  
3 1     1   5 use parent qw(Plack::Middleware::Session);
  1         1  
  1         3  
4              
5 1         3 use Plack::Util::Accessor qw(secret session_key domain expires path secure httponly
6 1     1   44 serializer deserializer);
  1         2  
7              
8 1     1   88 use Digest::HMAC_SHA1;
  1         3  
  1         29  
9 1     1   366 use MIME::Base64 ();
  1         504  
  1         19  
10 1     1   455 use Storable ();
  1         2507  
  1         22  
11 1     1   382 use Time::HiRes;
  1         999  
  1         4  
12 1     1   85 use Plack::Util;
  1         2  
  1         21  
13              
14 1     1   379 use Plack::Session::State::Cookie;
  1         3  
  1         516  
15              
16             sub prepare_app {
17 1     1 1 129 my $self = shift;
18              
19 1 50       4 die "Plack::Session::Middleware::Cookie requires setting 'secret' option."
20             unless $self->secret;
21              
22 1 50       45 $self->session_key("plack_session") unless $self->session_key;
23              
24 0     0   0 $self->serializer(sub {MIME::Base64::encode(Storable::nfreeze($_[0]), '' )})
25 1 50       12 unless $self->serializer;
26              
27 0     0   0 $self->deserializer(sub {Storable::thaw(MIME::Base64::decode($_[0]))})
28 1 50       12 unless $self->deserializer;
29              
30 1         19 $self->state( Plack::Session::State::Cookie->new );
31 1         7 for my $attr (qw(session_key path domain expires secure httponly)) {
32 6         51 $self->state->$attr($self->$attr);
33             }
34             }
35              
36             sub _compare {
37 0     0     my($s1, $s2) = @_;
38              
39 0 0         return if length $s1 != length $s2;
40 0           my $r = 0;
41 0           for my $i (0..length($s1) - 1) {
42 0           $r |= ord(substr $s1, $i) ^ ord(substr $s2, $i);
43             }
44              
45 0           return $r == 0;
46             }
47              
48             sub get_session {
49 0     0 0   my($self, $request) = @_;
50              
51 0 0         my $cookie = $self->state->get_session_id($request) or return;
52              
53 0           my($time, $b64, $sig) = split /:/, $cookie, 3;
54 0 0         _compare($self->sig($b64), $sig) or return;
55              
56             # NOTE: do something with $time?
57              
58 0           my $session = $self->deserializer->($b64);
59 0           return ($self->generate_id, $session);
60             }
61              
62             sub generate_id {
63 0     0 0   my $self = shift;
64 0           return scalar Time::HiRes::gettimeofday;
65             }
66              
67       0 0   sub commit { }
68              
69             sub change_id {
70 0     0 1   my($self, $env) = @_;
71              
72 0           my $options = $env->{'psgix.session.options'};
73              
74 0           $options->{id} = $self->generate_id($env);
75             }
76              
77             sub expire_session {
78 0     0 0   my($self, $id, $res, $env) = @_;
79 0           $self->state->expire_session_id($id, $res, $env->{'psgix.session.options'});
80             }
81              
82             sub save_state {
83 0     0 0   my($self, $id, $res, $env) = @_;
84              
85 0           my $cookie = $self->_serialize($id, $env->{'psgix.session'});
86 0           $self->state->finalize($cookie, $res, $env->{'psgix.session.options'});
87             }
88              
89             sub _serialize {
90 0     0     my($self, $id, $session) = @_;
91              
92 0           my $b64 = $self->serializer->($session);
93 0           join ":", $id, $b64, $self->sig($b64);
94             }
95              
96             sub sig {
97 0     0 0   my($self, $b64) = @_;
98 0 0         return '.' unless $self->secret;
99 0           Digest::HMAC_SHA1::hmac_sha1_hex($b64, $self->secret);
100             }
101              
102             1;
103              
104             __END__