File Coverage

blib/lib/Rubric/WebApp/Session.pm
Criterion Covered Total %
statement 56 59 94.9
branch 9 12 75.0
condition 4 6 66.6
subroutine 17 18 94.4
pod 4 4 100.0
total 90 99 90.9


line stmt bran cond sub pod time code
1 3     3   15 use strict;
  3         6  
  3         75  
2 3     3   15 use warnings;
  3         5  
  3         132  
3             package Rubric::WebApp::Session;
4             # ABSTRACT: the Rubric session plugin
5             $Rubric::WebApp::Session::VERSION = '0.156';
6 3     3   2977 use CGI::Cookie;
  3         17852  
  3         95  
7 3     3   2734 use Crypt::CBC;
  3         13459  
  3         103  
8 3     3   3306 use JSON 2 ();
  3         39049  
  3         78  
9 3     3   2336 use MIME::Base64;
  3         1973  
  3         362  
10 3         78 use Sub::Exporter -setup => {
11             -as => '_import',
12             exports => [
13             qw(session session_cipherer get_cookie_payload set_cookie_payload)
14             ],
15             groups => [ default => [ -all ] ],
16 3     3   23 };
  3         7  
17              
18             sub import {
19 3     3   6 my ($self) = @_;
20 3         12 my $caller = caller;
21              
22 3 50       26 Carp::croak "no session_cipher_key key set"
23             unless Rubric::Config->session_cipher_key;
24              
25 3         48 $caller->add_callback(init => 'get_cookie_payload');
26 3         56 $caller->add_callback(postrun => 'set_cookie_payload');
27 3         45 $self->_import({ into => $caller });
28             }
29              
30             #pod =head1 METHODS
31             #pod
32             #pod These methods are imported into the using class and should be called on an
33             #pod object of that type -- here, a Rubric::WebApp.
34             #pod
35             #pod =head2 session
36             #pod
37             #pod This returns the session, a hashref.
38             #pod
39             #pod =cut
40              
41             sub session {
42 338     338 1 1738 my ($self) = @_;
43 338   66     1847 return $self->{__PACKAGE__}{session} ||= $self->get_cookie_payload;
44             }
45              
46             my $COOKIE_NAME = 'RubricSession';
47              
48 2     2   193 sub __empty { Rubric::WebApp::Session::Object->new({}) }
49              
50             #pod =head2 session_cipherer
51             #pod
52             #pod This returns a Crypt::CBC object for handling ciphering.
53             #pod
54             #pod =cut
55              
56             sub session_cipherer {
57 142     142 1 282 my ($self) = @_;
58              
59 142   66     1395 $self->{__PACKAGE__}{cipherer} ||= Crypt::CBC->new(
60             -key => Rubric::Config->session_cipher_key,
61             -cipher => 'Rijndael',
62             -padding => 'standard',
63             );
64             }
65              
66             #pod =head2 get_cookie_payload
67             #pod
68             #pod This gets the cookie and returns the payload as a R::WA::Session::Object.
69             #pod
70             #pod =cut
71              
72             sub get_cookie_payload {
73 96     96 1 2093928 my ($self) = @_;
74              
75 96 100       403 return __empty unless my $cookie_value = $self->query->cookie($COOKIE_NAME);
76              
77 94         37973 my $cipherer = $self->session_cipherer;
78              
79 94         6846 my $data = eval {
80 94         1515 JSON->new->utf8->decode(
81             $cipherer->decrypt(decode_base64($cookie_value))
82             );
83             };
84              
85 94 50       17611 my $session = $data ? Rubric::WebApp::Session::Object->new($data) : __empty;
86             }
87              
88             #pod =head2 set_cookie_payload
89             #pod
90             #pod This method writes the session data back out to a cookie entry.
91             #pod
92             #pod =cut
93              
94             sub set_cookie_payload {
95 48     48 1 4755 my ($self) = @_;
96              
97 48         107 my $cookie_value = eval {
98 48         737 my $json = JSON->new->utf8->encode($self->session->as_hash);
99              
100 48         367 encode_base64($self->session_cipherer->encrypt($json));
101             };
102              
103 48         66916 my $cookie = CGI::Cookie->new(
104             -name => $COOKIE_NAME,
105             -expires => '+30d',
106             -value => $cookie_value,
107             -secure => Rubric::Config->cookie_secure,
108             -httponly => Rubric::Config->cookie_httponly,
109             );
110              
111 48         13245 $self->header_add(-cookie => [ $cookie ]);
112             }
113              
114             #pod =head1 SESSION OBJECT METHODS
115             #pod
116             #pod =cut
117              
118             package Rubric::WebApp::Session::Object;
119             $Rubric::WebApp::Session::Object::VERSION = '0.156';
120             #pod =head2 new
121             #pod
122             #pod This makes a new session object. You don't need this.
123             #pod
124             #pod =cut
125              
126             sub new {
127 96     96   284 my ($class, $data) = @_;
128 96         611 bless $data => $class;
129             }
130              
131             #pod =head2 param
132             #pod
133             #pod $obj->param('foo'); # get
134             #pod $obj->param('foo', 'val'); # set
135             #pod
136             #pod =cut
137              
138             sub param {
139 289     289   1476 my $self = shift;
140              
141 289 100       799 if (@_ == 1) {
142 224 100       1718 return $self->{$_[0]} if exists $self->{$_[0]};
143 36         270 return;
144             }
145              
146 65 50       238 if (@_ == 2) {
147 65         219 return $self->{$_[0]} = $_[1];
148             }
149              
150 0         0 die "invalid number of args to session->param";
151             }
152              
153             #pod =head2 clear
154             #pod
155             #pod $obj->clear('name');
156             #pod
157             #pod Clear the entry (delete it entirely) from the session.
158             #pod
159             #pod =cut
160              
161             sub clear {
162 1     1   4 my ($self, $param) = @_;
163 1         5 delete $self->{$param};
164             }
165              
166             #pod =head2 delete
167             #pod
168             #pod $session->delete;
169             #pod
170             #pod Removes all data from the session.
171             #pod
172             #pod =cut
173              
174             sub delete {
175 0     0   0 my ($self) = @_;
176 0         0 %$self = ();
177             }
178              
179             #pod =head2 as_hash
180             #pod
181             #pod This returns a hashref containing the session data.
182             #pod
183             #pod =cut
184              
185             sub as_hash {
186 48     48   127 return { %{ $_[0] } };
  48         492  
187             }
188              
189             1;
190              
191             __END__